This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Add a few useful developers maketargets to win32/Makefile
[perl5.git] / ext / B / t / deparse.t
CommitLineData
87a42246
MS
1#!./perl
2
3BEGIN {
5638aaac
SM
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
NC
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
MS
20}
21
22$| = 1;
23use warnings;
24use strict;
25use Config;
26
31c6271a 27print "1..42\n";
87a42246
MS
28
29use B::Deparse;
30my $deparse = B::Deparse->new() or print "not ";
ad46c0be 31my $i=1;
d4a0c6f3 32print "ok " . $i++ . "\n";
ad46c0be 33
87a42246
MS
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
MS
38 $deparse->ambient_pragmas (
39 hint_bits => $hint_bits,
40 warning_bits => $warning_bits,
41 '$[' => 0 + $[
42 );
43}
44
ad46c0be
RH
45$/ = "\n####\n";
46while (<DATA>) {
47 chomp;
48 s/#.*$//mg;
87a42246 49
ad46c0be
RH
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
RH
62 print "# $@";
63 }
64 else {
65 my $deparsed = $deparse->coderef2text( $coderef );
31c6271a
RD
66 my $regex = $expected;
67 $regex =~ s/(\S+)/\Q$1/g;
68 $regex =~ s/\s+/\\s+/g;
69 $regex = '^\{\s*' . $regex . '\s*\}$';
ad46c0be 70
31c6271a 71 my $ok = ($deparsed =~ /$regex/);
d4a0c6f3 72 print (($ok ? "ok " : "not ok ") . $i++ . "\n");
ad46c0be
RH
73 if (!$ok) {
74 print "# EXPECTED:\n";
75 $regex =~ s/^/# /mg;
76 print "$regex\n";
77
78 print "\n# GOT: \n";
79 $deparsed =~ s/^/# /mg;
80 print "$deparsed\n";
81 }
87a42246 82 }
87a42246
MS
83}
84
87a42246
MS
85use constant 'c', 'stuff';
86print "not " if (eval "sub ".$deparse->coderef2text(\&c))->() ne 'stuff';
d4a0c6f3 87print "ok " . $i++ . "\n";
87a42246
MS
88
89$a = 0;
90print "not " if "{\n (-1) ** \$a;\n}"
91 ne $deparse->coderef2text(sub{(-1) ** $a });
d4a0c6f3 92print "ok " . $i++ . "\n";
87a42246 93
d989cdac
SM
94use constant cr => ['hello'];
95my $string = "sub " . $deparse->coderef2text(\&cr);
96my $val = (eval $string)->();
97print "not " if ref($val) ne 'ARRAY' || $val->[0] ne 'hello';
98print "ok " . $i++ . "\n";
87a42246
MS
99
100my $a;
101my $Is_VMS = $^O eq 'VMS';
102my $Is_MacOS = $^O eq 'MacOS';
103
104my $path = join " ", map { qq["-I$_"] } @INC;
be708cc0 105$path .= " -MMac::err=unix" if $Is_MacOS;
87a42246
MS
106my $redir = $Is_MacOS ? "" : "2>&1";
107
d2bc402e 108$a = `$^X $path "-MO=Deparse" -anlwi.bak -e 1 $redir`;
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
114BEGIN { $^I = ".bak"; }
115BEGIN { $^W = 1; }
116BEGIN { $/ = "\n"; $\ = "\n"; }
87a42246
MS
117LINE: while (defined($_ = <ARGV>)) {
118 chomp $_;
f86ea535 119 our(@F) = split(' ', $_, 0);
87a42246
MS
120 '???';
121}
87a42246 122EOF
e69a2255
JH
123$b =~ s/(LINE:)/sub BEGIN {
124 'MacPerl'->bootstrap;
125 'OSA'->bootstrap;
126 'XL'->bootstrap;
127}
128$1/ if $Is_MacOS;
7204222c 129print "# [$a]\n\# vs expected\n# [$b]\nnot " if $a ne $b;
d4a0c6f3 130print "ok " . $i++ . "\n";
87a42246 131
579a54dc 132#Re: perlbug #35857, patch #24505
b3980c39
YO
133#handle warnings::register-ed packages properly.
134package B::Deparse::Wrapper;
135use strict;
136use warnings;
137use warnings::register;
138sub getcode {
579a54dc 139 my $deparser = B::Deparse->new();
b3980c39
YO
140 return $deparser->coderef2text(shift);
141}
142
143package main;
144use strict;
145use warnings;
146sub test {
579a54dc
RGS
147 my $val = shift;
148 my $res = B::Deparse::Wrapper::getcode($val);
149 print $res =~ /use warnings/ ? '' : 'not ', 'ok ', $i++, "\n";
b3980c39
YO
150}
151my ($q,$p);
152my $x=sub { ++$q,++$p };
153test($x);
154eval <<EOFCODE and test($x);
155 package bar;
156 use strict;
157 use warnings;
158 use warnings::register;
159 package main;
160 1
161EOFCODE
162
ad46c0be 163__DATA__
14a55f98 164# 2
ad46c0be
RH
1651;
166####
14a55f98 167# 3
ad46c0be
RH
168{
169 no warnings;
170 '???';
171 2;
172}
173####
14a55f98 174# 4
ad46c0be
RH
175my $test;
176++$test and $test /= 2;
177>>>>
178my $test;
179$test /= 2 if ++$test;
180####
14a55f98 181# 5
ad46c0be
RH
182-((1, 2) x 2);
183####
14a55f98 184# 6
ad46c0be
RH
185{
186 my $test = sub : lvalue {
187 my $x;
188 }
189 ;
190}
191####
14a55f98 192# 7
ad46c0be
RH
193{
194 my $test = sub : method {
195 my $x;
196 }
197 ;
198}
199####
14a55f98 200# 8
ad46c0be
RH
201{
202 my $test = sub : locked method {
203 my $x;
204 }
205 ;
206}
207####
14a55f98 208# 9
87a42246 209{
ad46c0be 210 234;
f99a63a2 211}
ad46c0be
RH
212continue {
213 123;
87a42246 214}
ce4e655d 215####
14a55f98 216# 10
ce4e655d
RH
217my $x;
218print $main::x;
219####
14a55f98 220# 11
ce4e655d
RH
221my @x;
222print $main::x[1];
14a55f98
RH
223####
224# 12
225my %x;
226$x{warn()};
ad8caead
RGS
227####
228# 13
229my $foo;
230$_ .= <ARGV> . <$foo>;
cef22867
JH
231####
232# 14
233my $foo = "Ab\x{100}\200\x{200}\377Cd\000Ef\x{1000}\cA\x{2000}\cZ";
4ae52e81
RGS
234####
235# 15
236s/x/'y';/e;
241416b8
DM
237####
238# 16 - various lypes of loop
239{ my $x; }
240####
241# 17
242while (1) { my $k; }
243####
244# 18
245my ($x,@a);
246$x=1 for @a;
247>>>>
248my($x, @a);
0bb5f065 249$x = 1 foreach (@a);
241416b8
DM
250####
251# 19
252for (my $i = 0; $i < 2;) {
253 my $z = 1;
254}
255####
256# 20
257for (my $i = 0; $i < 2; ++$i) {
258 my $z = 1;
259}
260####
261# 21
262for (my $i = 0; $i < 2; ++$i) {
263 my $z = 1;
264}
265####
266# 22
267my $i;
268while ($i) { my $z = 1; } continue { $i = 99; }
269####
270# 23
271foreach $i (1, 2) {
272 my $z = 1;
273}
274####
275# 24
276my $i;
277foreach $i (1, 2) {
278 my $z = 1;
279}
280####
281# 25
282my $i;
283foreach my $i (1, 2) {
284 my $z = 1;
285}
286####
287# 26
288foreach my $i (1, 2) {
289 my $z = 1;
290}
291####
292# 27
293foreach our $i (1, 2) {
294 my $z = 1;
295}
296####
297# 28
298my $i;
299foreach our $i (1, 2) {
300 my $z = 1;
301}
3ac6e0f9
RGS
302####
303# 29
304my @x;
305print reverse sort(@x);
306####
307# 30
308my @x;
309print((sort {$b cmp $a} @x));
310####
311# 31
312my @x;
313print((reverse sort {$b <=> $a} @x));
36d57d93
RGS
314####
315# 32
316our @a;
317print $_ foreach (reverse @a);
aae53c41 318####
579a54dc 319# 33
aae53c41
RGS
320our @a;
321print $_ foreach (reverse 1, 2..5);
f86ea535
SM
322####
323# 34 (bug #38684)
324our @ary;
325@ary = split(' ', 'foo', 0);
31c6271a
RD
326####
327# 35 (bug #40055)
328do { () };
329####
330# 36 (ibid.)
331do { my $x = 1; $x };