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