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