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