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