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 | } |
0707d6cc |
30 | use Test::More tests => 57; |
87a42246 |
31 | |
32 | use B::Deparse; |
09d856fb |
33 | my $deparse = B::Deparse->new(); |
34 | ok($deparse); |
87a42246 |
35 | |
36 | # Tell B::Deparse about our ambient pragmas |
0ced6c29 |
37 | { my ($hint_bits, $warning_bits, $hinthash); |
38 | BEGIN { ($hint_bits, $warning_bits, $hinthash) = ($^H, ${^WARNING_BITS}, \%^H); } |
87a42246 |
39 | $deparse->ambient_pragmas ( |
40 | hint_bits => $hint_bits, |
41 | warning_bits => $warning_bits, |
0ced6c29 |
42 | '$[' => 0 + $[, |
43 | '%^H' => $hinthash, |
87a42246 |
44 | ); |
45 | } |
46 | |
ad46c0be |
47 | $/ = "\n####\n"; |
48 | while (<DATA>) { |
49 | chomp; |
e9c69003 |
50 | # This code is pinched from the t/lib/common.pl for TODO. |
51 | # It's not clear how to avoid duplication |
52 | my ($skip, $skip_reason); |
53 | s/^#\s*SKIP\s*(.*)\n//m and $skip_reason = $1; |
54 | # If the SKIP reason starts ? then it's taken as a code snippet to evaluate |
55 | # This provides the flexibility to have conditional SKIPs |
56 | if ($skip_reason && $skip_reason =~ s/^\?//) { |
57 | my $temp = eval $skip_reason; |
58 | if ($@) { |
59 | die "# In SKIP code reason:\n# $skip_reason\n$@"; |
60 | } |
61 | $skip_reason = $temp; |
62 | } |
63 | |
ec59cdf2 |
64 | s/#\s*(.*)$//mg; |
65 | my ($num, $testname) = $1 =~ m/(\d+)\s*(.*)/; |
e9c69003 |
66 | |
67 | if ($skip_reason) { |
68 | # Like this to avoid needing a label SKIP: |
69 | Test::More->builder->skip($skip_reason); |
70 | next; |
71 | } |
72 | |
ad46c0be |
73 | my ($input, $expected); |
74 | if (/(.*)\n>>>>\n(.*)/s) { |
75 | ($input, $expected) = ($1, $2); |
76 | } |
77 | else { |
78 | ($input, $expected) = ($_, $_); |
79 | } |
87a42246 |
80 | |
ad46c0be |
81 | my $coderef = eval "sub {$input}"; |
87a42246 |
82 | |
ad46c0be |
83 | if ($@) { |
ec59cdf2 |
84 | diag("$num deparsed: $@"); |
85 | ok(0, $testname); |
ad46c0be |
86 | } |
87 | else { |
88 | my $deparsed = $deparse->coderef2text( $coderef ); |
31c6271a |
89 | my $regex = $expected; |
90 | $regex =~ s/(\S+)/\Q$1/g; |
91 | $regex =~ s/\s+/\\s+/g; |
92 | $regex = '^\{\s*' . $regex . '\s*\}$'; |
ec59cdf2 |
93 | like($deparsed, qr/$regex/, $testname); |
87a42246 |
94 | } |
87a42246 |
95 | } |
96 | |
87a42246 |
97 | use constant 'c', 'stuff'; |
09d856fb |
98 | is((eval "sub ".$deparse->coderef2text(\&c))->(), 'stuff'); |
87a42246 |
99 | |
09d856fb |
100 | my $a = 0; |
101 | is("{\n (-1) ** \$a;\n}", $deparse->coderef2text(sub{(-1) ** $a })); |
87a42246 |
102 | |
d989cdac |
103 | use constant cr => ['hello']; |
104 | my $string = "sub " . $deparse->coderef2text(\&cr); |
0707d6cc |
105 | my $val = (eval $string)->() or diag $string; |
106 | is(ref($val), 'ARRAY'); |
107 | is($val->[0], 'hello'); |
87a42246 |
108 | |
87a42246 |
109 | my $Is_VMS = $^O eq 'VMS'; |
110 | my $Is_MacOS = $^O eq 'MacOS'; |
111 | |
112 | my $path = join " ", map { qq["-I$_"] } @INC; |
be708cc0 |
113 | $path .= " -MMac::err=unix" if $Is_MacOS; |
87a42246 |
114 | my $redir = $Is_MacOS ? "" : "2>&1"; |
115 | |
d2bc402e |
116 | $a = `$^X $path "-MO=Deparse" -anlwi.bak -e 1 $redir`; |
e69a2255 |
117 | $a =~ s/-e syntax OK\n//g; |
d2bc402e |
118 | $a =~ s/.*possible typo.*\n//; # Remove warning line |
87a42246 |
119 | $a =~ s{\\340\\242}{\\s} if (ord("\\") == 224); # EBCDIC, cp 1047 or 037 |
120 | $a =~ s{\\274\\242}{\\s} if (ord("\\") == 188); # $^O eq 'posix-bc' |
121 | $b = <<'EOF'; |
d2bc402e |
122 | BEGIN { $^I = ".bak"; } |
123 | BEGIN { $^W = 1; } |
124 | BEGIN { $/ = "\n"; $\ = "\n"; } |
87a42246 |
125 | LINE: while (defined($_ = <ARGV>)) { |
126 | chomp $_; |
f86ea535 |
127 | our(@F) = split(' ', $_, 0); |
87a42246 |
128 | '???'; |
129 | } |
87a42246 |
130 | EOF |
e69a2255 |
131 | $b =~ s/(LINE:)/sub BEGIN { |
132 | 'MacPerl'->bootstrap; |
133 | 'OSA'->bootstrap; |
134 | 'XL'->bootstrap; |
135 | } |
136 | $1/ if $Is_MacOS; |
09d856fb |
137 | is($a, $b); |
87a42246 |
138 | |
579a54dc |
139 | #Re: perlbug #35857, patch #24505 |
b3980c39 |
140 | #handle warnings::register-ed packages properly. |
141 | package B::Deparse::Wrapper; |
142 | use strict; |
143 | use warnings; |
144 | use warnings::register; |
145 | sub getcode { |
579a54dc |
146 | my $deparser = B::Deparse->new(); |
b3980c39 |
147 | return $deparser->coderef2text(shift); |
148 | } |
149 | |
150 | package main; |
151 | use strict; |
152 | use warnings; |
153 | sub test { |
579a54dc |
154 | my $val = shift; |
155 | my $res = B::Deparse::Wrapper::getcode($val); |
09d856fb |
156 | like( $res, qr/use warnings/); |
b3980c39 |
157 | } |
158 | my ($q,$p); |
159 | my $x=sub { ++$q,++$p }; |
160 | test($x); |
161 | eval <<EOFCODE and test($x); |
162 | package bar; |
163 | use strict; |
164 | use warnings; |
165 | use warnings::register; |
166 | package main; |
167 | 1 |
168 | EOFCODE |
169 | |
ad46c0be |
170 | __DATA__ |
14a55f98 |
171 | # 2 |
ad46c0be |
172 | 1; |
173 | #### |
14a55f98 |
174 | # 3 |
ad46c0be |
175 | { |
176 | no warnings; |
177 | '???'; |
178 | 2; |
179 | } |
180 | #### |
14a55f98 |
181 | # 4 |
ad46c0be |
182 | my $test; |
183 | ++$test and $test /= 2; |
184 | >>>> |
185 | my $test; |
186 | $test /= 2 if ++$test; |
187 | #### |
14a55f98 |
188 | # 5 |
ad46c0be |
189 | -((1, 2) x 2); |
190 | #### |
14a55f98 |
191 | # 6 |
ad46c0be |
192 | { |
193 | my $test = sub : lvalue { |
194 | my $x; |
195 | } |
196 | ; |
197 | } |
198 | #### |
14a55f98 |
199 | # 7 |
ad46c0be |
200 | { |
201 | my $test = sub : method { |
202 | my $x; |
203 | } |
204 | ; |
205 | } |
206 | #### |
14a55f98 |
207 | # 8 |
ad46c0be |
208 | { |
209 | my $test = sub : locked method { |
210 | my $x; |
211 | } |
212 | ; |
213 | } |
214 | #### |
14a55f98 |
215 | # 9 |
87a42246 |
216 | { |
ad46c0be |
217 | 234; |
f99a63a2 |
218 | } |
ad46c0be |
219 | continue { |
220 | 123; |
87a42246 |
221 | } |
ce4e655d |
222 | #### |
14a55f98 |
223 | # 10 |
ce4e655d |
224 | my $x; |
225 | print $main::x; |
226 | #### |
14a55f98 |
227 | # 11 |
ce4e655d |
228 | my @x; |
229 | print $main::x[1]; |
14a55f98 |
230 | #### |
231 | # 12 |
232 | my %x; |
233 | $x{warn()}; |
ad8caead |
234 | #### |
235 | # 13 |
236 | my $foo; |
237 | $_ .= <ARGV> . <$foo>; |
cef22867 |
238 | #### |
239 | # 14 |
240 | my $foo = "Ab\x{100}\200\x{200}\377Cd\000Ef\x{1000}\cA\x{2000}\cZ"; |
4ae52e81 |
241 | #### |
242 | # 15 |
243 | s/x/'y';/e; |
241416b8 |
244 | #### |
245 | # 16 - various lypes of loop |
246 | { my $x; } |
247 | #### |
248 | # 17 |
249 | while (1) { my $k; } |
250 | #### |
251 | # 18 |
252 | my ($x,@a); |
253 | $x=1 for @a; |
254 | >>>> |
255 | my($x, @a); |
0bb5f065 |
256 | $x = 1 foreach (@a); |
241416b8 |
257 | #### |
258 | # 19 |
259 | for (my $i = 0; $i < 2;) { |
260 | my $z = 1; |
261 | } |
262 | #### |
263 | # 20 |
264 | for (my $i = 0; $i < 2; ++$i) { |
265 | my $z = 1; |
266 | } |
267 | #### |
268 | # 21 |
269 | for (my $i = 0; $i < 2; ++$i) { |
270 | my $z = 1; |
271 | } |
272 | #### |
273 | # 22 |
274 | my $i; |
275 | while ($i) { my $z = 1; } continue { $i = 99; } |
276 | #### |
277 | # 23 |
09d856fb |
278 | foreach my $i (1, 2) { |
241416b8 |
279 | my $z = 1; |
280 | } |
281 | #### |
282 | # 24 |
283 | my $i; |
284 | foreach $i (1, 2) { |
285 | my $z = 1; |
286 | } |
287 | #### |
288 | # 25 |
289 | my $i; |
290 | foreach my $i (1, 2) { |
291 | my $z = 1; |
292 | } |
293 | #### |
294 | # 26 |
295 | foreach my $i (1, 2) { |
296 | my $z = 1; |
297 | } |
298 | #### |
299 | # 27 |
300 | foreach our $i (1, 2) { |
301 | my $z = 1; |
302 | } |
303 | #### |
304 | # 28 |
305 | my $i; |
306 | foreach our $i (1, 2) { |
307 | my $z = 1; |
308 | } |
3ac6e0f9 |
309 | #### |
310 | # 29 |
311 | my @x; |
312 | print reverse sort(@x); |
313 | #### |
314 | # 30 |
315 | my @x; |
316 | print((sort {$b cmp $a} @x)); |
317 | #### |
318 | # 31 |
319 | my @x; |
320 | print((reverse sort {$b <=> $a} @x)); |
36d57d93 |
321 | #### |
322 | # 32 |
323 | our @a; |
324 | print $_ foreach (reverse @a); |
aae53c41 |
325 | #### |
579a54dc |
326 | # 33 |
aae53c41 |
327 | our @a; |
328 | print $_ foreach (reverse 1, 2..5); |
f86ea535 |
329 | #### |
330 | # 34 (bug #38684) |
331 | our @ary; |
332 | @ary = split(' ', 'foo', 0); |
31c6271a |
333 | #### |
334 | # 35 (bug #40055) |
335 | do { () }; |
336 | #### |
337 | # 36 (ibid.) |
338 | do { my $x = 1; $x }; |
d9002312 |
339 | #### |
340 | # 37 <20061012113037.GJ25805@c4.convolution.nl> |
341 | my $f = sub { |
342 | +{[]}; |
343 | } ; |
8b2d6640 |
344 | #### |
345 | # 38 (bug #43010) |
346 | '!@$%'->(); |
347 | #### |
348 | # 39 (ibid.) |
349 | ::(); |
350 | #### |
351 | # 40 (ibid.) |
352 | '::::'->(); |
353 | #### |
354 | # 41 (ibid.) |
355 | &::::; |
09d856fb |
356 | #### |
357 | # 42 |
358 | my $bar; |
359 | 'Foo'->$bar('orz'); |
360 | #### |
361 | # 43 |
362 | 'Foo'->bar('orz'); |
363 | #### |
364 | # 44 |
365 | 'Foo'->bar; |
0ced6c29 |
366 | #### |
e9c69003 |
367 | # SKIP ?$] < 5.010 && "say not implemented on this Perl version" |
7ddd1a01 |
368 | # 45 say |
369 | say 'foo'; |
370 | #### |
e9c69003 |
371 | # SKIP ?$] < 5.010 && "state vars not implemented on this Perl version" |
7ddd1a01 |
372 | # 46 state vars |
0ced6c29 |
373 | state $x = 42; |
374 | #### |
e9c69003 |
375 | # SKIP ?$] < 5.010 && "state vars not implemented on this Perl version" |
7ddd1a01 |
376 | # 47 state var assignment |
377 | { |
378 | my $y = (state $x = 42); |
379 | } |
380 | #### |
e9c69003 |
381 | # SKIP ?$] < 5.010 && "state vars not implemented on this Perl version" |
7ddd1a01 |
382 | # 48 state vars in anoymous subroutines |
383 | $a = sub { |
384 | state $x; |
385 | return $x++; |
386 | } |
387 | ; |
644741fd |
388 | #### |
389 | # SKIP ?$] < 5.011 && 'each @array not implemented on this Perl version' |
390 | # 49 each @array; |
391 | each @ARGV; |
392 | each @$a; |
393 | #### |
394 | # SKIP ?$] < 5.011 && 'each @array not implemented on this Perl version' |
395 | # 50 keys @array; values @array |
396 | keys @$a if keys @ARGV; |
397 | values @ARGV if values @$a; |