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 | |
22 | $| = 1; |
23 | use warnings; |
24 | use strict; |
25 | use Config; |
26 | |
aae53c41 |
27 | print "1..37\n"; |
87a42246 |
28 | |
29 | use B::Deparse; |
30 | my $deparse = B::Deparse->new() or print "not "; |
ad46c0be |
31 | my $i=1; |
d4a0c6f3 |
32 | print "ok " . $i++ . "\n"; |
ad46c0be |
33 | |
87a42246 |
34 | |
35 | # Tell B::Deparse about our ambient pragmas |
36 | { my ($hint_bits, $warning_bits); |
b891b733 |
37 | BEGIN { ($hint_bits, $warning_bits) = ($^H, ${^WARNING_BITS}); } |
87a42246 |
38 | $deparse->ambient_pragmas ( |
39 | hint_bits => $hint_bits, |
40 | warning_bits => $warning_bits, |
41 | '$[' => 0 + $[ |
42 | ); |
43 | } |
44 | |
ad46c0be |
45 | $/ = "\n####\n"; |
46 | while (<DATA>) { |
47 | chomp; |
48 | s/#.*$//mg; |
87a42246 |
49 | |
ad46c0be |
50 | my ($input, $expected); |
51 | if (/(.*)\n>>>>\n(.*)/s) { |
52 | ($input, $expected) = ($1, $2); |
53 | } |
54 | else { |
55 | ($input, $expected) = ($_, $_); |
56 | } |
87a42246 |
57 | |
ad46c0be |
58 | my $coderef = eval "sub {$input}"; |
87a42246 |
59 | |
ad46c0be |
60 | if ($@) { |
d4a0c6f3 |
61 | print "not ok " . $i++ . "\n"; |
ad46c0be |
62 | print "# $@"; |
63 | } |
64 | else { |
65 | my $deparsed = $deparse->coderef2text( $coderef ); |
66 | my $regex = quotemeta($expected); |
67 | do { |
68 | no warnings 'misc'; |
69 | $regex =~ s/\s+/\s+/g; |
70 | }; |
71 | |
72 | my $ok = ($deparsed =~ /^\{\s*$regex\s*\}$/); |
d4a0c6f3 |
73 | print (($ok ? "ok " : "not ok ") . $i++ . "\n"); |
ad46c0be |
74 | if (!$ok) { |
75 | print "# EXPECTED:\n"; |
76 | $regex =~ s/^/# /mg; |
77 | print "$regex\n"; |
78 | |
79 | print "\n# GOT: \n"; |
80 | $deparsed =~ s/^/# /mg; |
81 | print "$deparsed\n"; |
82 | } |
87a42246 |
83 | } |
87a42246 |
84 | } |
85 | |
87a42246 |
86 | use constant 'c', 'stuff'; |
87 | print "not " if (eval "sub ".$deparse->coderef2text(\&c))->() ne 'stuff'; |
d4a0c6f3 |
88 | print "ok " . $i++ . "\n"; |
87a42246 |
89 | |
90 | $a = 0; |
91 | print "not " if "{\n (-1) ** \$a;\n}" |
92 | ne $deparse->coderef2text(sub{(-1) ** $a }); |
d4a0c6f3 |
93 | print "ok " . $i++ . "\n"; |
87a42246 |
94 | |
d989cdac |
95 | use constant cr => ['hello']; |
96 | my $string = "sub " . $deparse->coderef2text(\&cr); |
97 | my $val = (eval $string)->(); |
98 | print "not " if ref($val) ne 'ARRAY' || $val->[0] ne 'hello'; |
99 | print "ok " . $i++ . "\n"; |
87a42246 |
100 | |
101 | my $a; |
102 | my $Is_VMS = $^O eq 'VMS'; |
103 | my $Is_MacOS = $^O eq 'MacOS'; |
104 | |
105 | my $path = join " ", map { qq["-I$_"] } @INC; |
be708cc0 |
106 | $path .= " -MMac::err=unix" if $Is_MacOS; |
87a42246 |
107 | my $redir = $Is_MacOS ? "" : "2>&1"; |
108 | |
d2bc402e |
109 | $a = `$^X $path "-MO=Deparse" -anlwi.bak -e 1 $redir`; |
e69a2255 |
110 | $a =~ s/-e syntax OK\n//g; |
d2bc402e |
111 | $a =~ s/.*possible typo.*\n//; # Remove warning line |
87a42246 |
112 | $a =~ s{\\340\\242}{\\s} if (ord("\\") == 224); # EBCDIC, cp 1047 or 037 |
113 | $a =~ s{\\274\\242}{\\s} if (ord("\\") == 188); # $^O eq 'posix-bc' |
114 | $b = <<'EOF'; |
d2bc402e |
115 | BEGIN { $^I = ".bak"; } |
116 | BEGIN { $^W = 1; } |
117 | BEGIN { $/ = "\n"; $\ = "\n"; } |
87a42246 |
118 | LINE: while (defined($_ = <ARGV>)) { |
119 | chomp $_; |
14a55f98 |
120 | our(@F) = split(" ", $_, 0); |
87a42246 |
121 | '???'; |
122 | } |
87a42246 |
123 | EOF |
e69a2255 |
124 | $b =~ s/(LINE:)/sub BEGIN { |
125 | 'MacPerl'->bootstrap; |
126 | 'OSA'->bootstrap; |
127 | 'XL'->bootstrap; |
128 | } |
129 | $1/ if $Is_MacOS; |
7204222c |
130 | print "# [$a]\n\# vs expected\n# [$b]\nnot " if $a ne $b; |
d4a0c6f3 |
131 | print "ok " . $i++ . "\n"; |
87a42246 |
132 | |
ad46c0be |
133 | __DATA__ |
14a55f98 |
134 | # 2 |
ad46c0be |
135 | 1; |
136 | #### |
14a55f98 |
137 | # 3 |
ad46c0be |
138 | { |
139 | no warnings; |
140 | '???'; |
141 | 2; |
142 | } |
143 | #### |
14a55f98 |
144 | # 4 |
ad46c0be |
145 | my $test; |
146 | ++$test and $test /= 2; |
147 | >>>> |
148 | my $test; |
149 | $test /= 2 if ++$test; |
150 | #### |
14a55f98 |
151 | # 5 |
ad46c0be |
152 | -((1, 2) x 2); |
153 | #### |
14a55f98 |
154 | # 6 |
ad46c0be |
155 | { |
156 | my $test = sub : lvalue { |
157 | my $x; |
158 | } |
159 | ; |
160 | } |
161 | #### |
14a55f98 |
162 | # 7 |
ad46c0be |
163 | { |
164 | my $test = sub : method { |
165 | my $x; |
166 | } |
167 | ; |
168 | } |
169 | #### |
14a55f98 |
170 | # 8 |
ad46c0be |
171 | { |
172 | my $test = sub : locked method { |
173 | my $x; |
174 | } |
175 | ; |
176 | } |
177 | #### |
14a55f98 |
178 | # 9 |
87a42246 |
179 | { |
ad46c0be |
180 | 234; |
f99a63a2 |
181 | } |
ad46c0be |
182 | continue { |
183 | 123; |
87a42246 |
184 | } |
ce4e655d |
185 | #### |
14a55f98 |
186 | # 10 |
ce4e655d |
187 | my $x; |
188 | print $main::x; |
189 | #### |
14a55f98 |
190 | # 11 |
ce4e655d |
191 | my @x; |
192 | print $main::x[1]; |
14a55f98 |
193 | #### |
194 | # 12 |
195 | my %x; |
196 | $x{warn()}; |
ad8caead |
197 | #### |
198 | # 13 |
199 | my $foo; |
200 | $_ .= <ARGV> . <$foo>; |
cef22867 |
201 | #### |
202 | # 14 |
203 | my $foo = "Ab\x{100}\200\x{200}\377Cd\000Ef\x{1000}\cA\x{2000}\cZ"; |
4ae52e81 |
204 | #### |
205 | # 15 |
206 | s/x/'y';/e; |
241416b8 |
207 | #### |
208 | # 16 - various lypes of loop |
209 | { my $x; } |
210 | #### |
211 | # 17 |
212 | while (1) { my $k; } |
213 | #### |
214 | # 18 |
215 | my ($x,@a); |
216 | $x=1 for @a; |
217 | >>>> |
218 | my($x, @a); |
0bb5f065 |
219 | $x = 1 foreach (@a); |
241416b8 |
220 | #### |
221 | # 19 |
222 | for (my $i = 0; $i < 2;) { |
223 | my $z = 1; |
224 | } |
225 | #### |
226 | # 20 |
227 | for (my $i = 0; $i < 2; ++$i) { |
228 | my $z = 1; |
229 | } |
230 | #### |
231 | # 21 |
232 | for (my $i = 0; $i < 2; ++$i) { |
233 | my $z = 1; |
234 | } |
235 | #### |
236 | # 22 |
237 | my $i; |
238 | while ($i) { my $z = 1; } continue { $i = 99; } |
239 | #### |
240 | # 23 |
241 | foreach $i (1, 2) { |
242 | my $z = 1; |
243 | } |
244 | #### |
245 | # 24 |
246 | my $i; |
247 | foreach $i (1, 2) { |
248 | my $z = 1; |
249 | } |
250 | #### |
251 | # 25 |
252 | my $i; |
253 | foreach my $i (1, 2) { |
254 | my $z = 1; |
255 | } |
256 | #### |
257 | # 26 |
258 | foreach my $i (1, 2) { |
259 | my $z = 1; |
260 | } |
261 | #### |
262 | # 27 |
263 | foreach our $i (1, 2) { |
264 | my $z = 1; |
265 | } |
266 | #### |
267 | # 28 |
268 | my $i; |
269 | foreach our $i (1, 2) { |
270 | my $z = 1; |
271 | } |
3ac6e0f9 |
272 | #### |
273 | # 29 |
274 | my @x; |
275 | print reverse sort(@x); |
276 | #### |
277 | # 30 |
278 | my @x; |
279 | print((sort {$b cmp $a} @x)); |
280 | #### |
281 | # 31 |
282 | my @x; |
283 | print((reverse sort {$b <=> $a} @x)); |
36d57d93 |
284 | #### |
285 | # 32 |
286 | our @a; |
287 | print $_ foreach (reverse @a); |
aae53c41 |
288 | #### |
289 | # 32 |
290 | our @a; |
291 | print $_ foreach (reverse 1, 2..5); |