This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
[perl #52860] [PATCH] Incorrect variable name in perlintro
[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;
e9c69003
NC
24BEGIN {
25 # BEGIN block is acutally a subroutine :-)
26 return unless $] > 5.009;
27 require feature;
28 feature->import(':5.10');
29}
9210de83 30use Test::More tests => 59;
87a42246
MS
31
32use B::Deparse;
09d856fb
CK
33my $deparse = B::Deparse->new();
34ok($deparse);
87a42246
MS
35
36# Tell B::Deparse about our ambient pragmas
0ced6c29
RGS
37{ my ($hint_bits, $warning_bits, $hinthash);
38 BEGIN { ($hint_bits, $warning_bits, $hinthash) = ($^H, ${^WARNING_BITS}, \%^H); }
87a42246
MS
39 $deparse->ambient_pragmas (
40 hint_bits => $hint_bits,
41 warning_bits => $warning_bits,
0ced6c29
RGS
42 '$[' => 0 + $[,
43 '%^H' => $hinthash,
87a42246
MS
44 );
45}
46
ad46c0be
RH
47$/ = "\n####\n";
48while (<DATA>) {
49 chomp;
e9c69003
NC
50 # This code is pinched from the t/lib/common.pl for TODO.
51 # It's not clear how to avoid duplication
52 my ($skip, $skip_reason);
53 s/^#\s*SKIP\s*(.*)\n//m and $skip_reason = $1;
54 # If the SKIP reason starts ? then it's taken as a code snippet to evaluate
55 # This provides the flexibility to have conditional SKIPs
56 if ($skip_reason && $skip_reason =~ s/^\?//) {
57 my $temp = eval $skip_reason;
58 if ($@) {
59 die "# In SKIP code reason:\n# $skip_reason\n$@";
60 }
61 $skip_reason = $temp;
62 }
63
ec59cdf2
RGS
64 s/#\s*(.*)$//mg;
65 my ($num, $testname) = $1 =~ m/(\d+)\s*(.*)/;
e9c69003
NC
66
67 if ($skip_reason) {
68 # Like this to avoid needing a label SKIP:
69 Test::More->builder->skip($skip_reason);
70 next;
71 }
72
ad46c0be
RH
73 my ($input, $expected);
74 if (/(.*)\n>>>>\n(.*)/s) {
75 ($input, $expected) = ($1, $2);
76 }
77 else {
78 ($input, $expected) = ($_, $_);
79 }
87a42246 80
ad46c0be 81 my $coderef = eval "sub {$input}";
87a42246 82
ad46c0be 83 if ($@) {
ec59cdf2
RGS
84 diag("$num deparsed: $@");
85 ok(0, $testname);
ad46c0be
RH
86 }
87 else {
88 my $deparsed = $deparse->coderef2text( $coderef );
31c6271a
RD
89 my $regex = $expected;
90 $regex =~ s/(\S+)/\Q$1/g;
91 $regex =~ s/\s+/\\s+/g;
92 $regex = '^\{\s*' . $regex . '\s*\}$';
ec59cdf2 93 like($deparsed, qr/$regex/, $testname);
87a42246 94 }
87a42246
MS
95}
96
87a42246 97use constant 'c', 'stuff';
09d856fb 98is((eval "sub ".$deparse->coderef2text(\&c))->(), 'stuff');
87a42246 99
09d856fb
CK
100my $a = 0;
101is("{\n (-1) ** \$a;\n}", $deparse->coderef2text(sub{(-1) ** $a }));
87a42246 102
d989cdac
SM
103use constant cr => ['hello'];
104my $string = "sub " . $deparse->coderef2text(\&cr);
0707d6cc
NC
105my $val = (eval $string)->() or diag $string;
106is(ref($val), 'ARRAY');
107is($val->[0], 'hello');
87a42246 108
87a42246
MS
109my $Is_VMS = $^O eq 'VMS';
110my $Is_MacOS = $^O eq 'MacOS';
111
112my $path = join " ", map { qq["-I$_"] } @INC;
be708cc0 113$path .= " -MMac::err=unix" if $Is_MacOS;
87a42246
MS
114my $redir = $Is_MacOS ? "" : "2>&1";
115
d2bc402e 116$a = `$^X $path "-MO=Deparse" -anlwi.bak -e 1 $redir`;
e69a2255 117$a =~ s/-e syntax OK\n//g;
d2bc402e 118$a =~ s/.*possible typo.*\n//; # Remove warning line
87a42246
MS
119$a =~ s{\\340\\242}{\\s} if (ord("\\") == 224); # EBCDIC, cp 1047 or 037
120$a =~ s{\\274\\242}{\\s} if (ord("\\") == 188); # $^O eq 'posix-bc'
121$b = <<'EOF';
d2bc402e
RGS
122BEGIN { $^I = ".bak"; }
123BEGIN { $^W = 1; }
124BEGIN { $/ = "\n"; $\ = "\n"; }
87a42246
MS
125LINE: while (defined($_ = <ARGV>)) {
126 chomp $_;
f86ea535 127 our(@F) = split(' ', $_, 0);
87a42246
MS
128 '???';
129}
87a42246 130EOF
e69a2255
JH
131$b =~ s/(LINE:)/sub BEGIN {
132 'MacPerl'->bootstrap;
133 'OSA'->bootstrap;
134 'XL'->bootstrap;
135}
136$1/ if $Is_MacOS;
09d856fb 137is($a, $b);
87a42246 138
579a54dc 139#Re: perlbug #35857, patch #24505
b3980c39
YO
140#handle warnings::register-ed packages properly.
141package B::Deparse::Wrapper;
142use strict;
143use warnings;
144use warnings::register;
145sub getcode {
579a54dc 146 my $deparser = B::Deparse->new();
b3980c39
YO
147 return $deparser->coderef2text(shift);
148}
149
150package main;
151use strict;
152use warnings;
153sub test {
579a54dc
RGS
154 my $val = shift;
155 my $res = B::Deparse::Wrapper::getcode($val);
09d856fb 156 like( $res, qr/use warnings/);
b3980c39
YO
157}
158my ($q,$p);
159my $x=sub { ++$q,++$p };
160test($x);
161eval <<EOFCODE and test($x);
162 package bar;
163 use strict;
164 use warnings;
165 use warnings::register;
166 package main;
167 1
168EOFCODE
169
ad46c0be 170__DATA__
14a55f98 171# 2
ad46c0be
RH
1721;
173####
14a55f98 174# 3
ad46c0be
RH
175{
176 no warnings;
177 '???';
178 2;
179}
180####
14a55f98 181# 4
ad46c0be
RH
182my $test;
183++$test and $test /= 2;
184>>>>
185my $test;
186$test /= 2 if ++$test;
187####
14a55f98 188# 5
ad46c0be
RH
189-((1, 2) x 2);
190####
14a55f98 191# 6
ad46c0be
RH
192{
193 my $test = sub : lvalue {
194 my $x;
195 }
196 ;
197}
198####
14a55f98 199# 7
ad46c0be
RH
200{
201 my $test = sub : method {
202 my $x;
203 }
204 ;
205}
206####
14a55f98 207# 8
ad46c0be
RH
208{
209 my $test = sub : locked method {
210 my $x;
211 }
212 ;
213}
214####
14a55f98 215# 9
87a42246 216{
ad46c0be 217 234;
f99a63a2 218}
ad46c0be
RH
219continue {
220 123;
87a42246 221}
ce4e655d 222####
14a55f98 223# 10
ce4e655d
RH
224my $x;
225print $main::x;
226####
14a55f98 227# 11
ce4e655d
RH
228my @x;
229print $main::x[1];
14a55f98
RH
230####
231# 12
232my %x;
233$x{warn()};
ad8caead
RGS
234####
235# 13
236my $foo;
237$_ .= <ARGV> . <$foo>;
cef22867
JH
238####
239# 14
240my $foo = "Ab\x{100}\200\x{200}\377Cd\000Ef\x{1000}\cA\x{2000}\cZ";
4ae52e81
RGS
241####
242# 15
243s/x/'y';/e;
241416b8
DM
244####
245# 16 - various lypes of loop
246{ my $x; }
247####
248# 17
249while (1) { my $k; }
250####
251# 18
252my ($x,@a);
253$x=1 for @a;
254>>>>
255my($x, @a);
0bb5f065 256$x = 1 foreach (@a);
241416b8
DM
257####
258# 19
259for (my $i = 0; $i < 2;) {
260 my $z = 1;
261}
262####
263# 20
264for (my $i = 0; $i < 2; ++$i) {
265 my $z = 1;
266}
267####
268# 21
269for (my $i = 0; $i < 2; ++$i) {
270 my $z = 1;
271}
272####
273# 22
274my $i;
275while ($i) { my $z = 1; } continue { $i = 99; }
276####
277# 23
09d856fb 278foreach my $i (1, 2) {
241416b8
DM
279 my $z = 1;
280}
281####
282# 24
283my $i;
284foreach $i (1, 2) {
285 my $z = 1;
286}
287####
288# 25
289my $i;
290foreach my $i (1, 2) {
291 my $z = 1;
292}
293####
294# 26
295foreach my $i (1, 2) {
296 my $z = 1;
297}
298####
299# 27
300foreach our $i (1, 2) {
301 my $z = 1;
302}
303####
304# 28
305my $i;
306foreach our $i (1, 2) {
307 my $z = 1;
308}
3ac6e0f9
RGS
309####
310# 29
311my @x;
312print reverse sort(@x);
313####
314# 30
315my @x;
316print((sort {$b cmp $a} @x));
317####
318# 31
319my @x;
320print((reverse sort {$b <=> $a} @x));
36d57d93
RGS
321####
322# 32
323our @a;
324print $_ foreach (reverse @a);
aae53c41 325####
579a54dc 326# 33
aae53c41
RGS
327our @a;
328print $_ foreach (reverse 1, 2..5);
f86ea535
SM
329####
330# 34 (bug #38684)
331our @ary;
332@ary = split(' ', 'foo', 0);
31c6271a
RD
333####
334# 35 (bug #40055)
335do { () };
336####
337# 36 (ibid.)
338do { my $x = 1; $x };
d9002312
SM
339####
340# 37 <20061012113037.GJ25805@c4.convolution.nl>
341my $f = sub {
342 +{[]};
343} ;
8b2d6640
FC
344####
345# 38 (bug #43010)
346'!@$%'->();
347####
348# 39 (ibid.)
349::();
350####
351# 40 (ibid.)
352'::::'->();
353####
354# 41 (ibid.)
355&::::;
09d856fb
CK
356####
357# 42
358my $bar;
359'Foo'->$bar('orz');
360####
361# 43
362'Foo'->bar('orz');
363####
364# 44
365'Foo'->bar;
0ced6c29 366####
e9c69003 367# SKIP ?$] < 5.010 && "say not implemented on this Perl version"
7ddd1a01
NC
368# 45 say
369say 'foo';
370####
e9c69003 371# SKIP ?$] < 5.010 && "state vars not implemented on this Perl version"
7ddd1a01 372# 46 state vars
0ced6c29
RGS
373state $x = 42;
374####
e9c69003 375# SKIP ?$] < 5.010 && "state vars not implemented on this Perl version"
7ddd1a01
NC
376# 47 state var assignment
377{
378 my $y = (state $x = 42);
379}
380####
e9c69003 381# SKIP ?$] < 5.010 && "state vars not implemented on this Perl version"
7ddd1a01
NC
382# 48 state vars in anoymous subroutines
383$a = sub {
384 state $x;
385 return $x++;
386}
387;
644741fd
NC
388####
389# SKIP ?$] < 5.011 && 'each @array not implemented on this Perl version'
390# 49 each @array;
391each @ARGV;
392each @$a;
393####
394# SKIP ?$] < 5.011 && 'each @array not implemented on this Perl version'
395# 50 keys @array; values @array
396keys @$a if keys @ARGV;
397values @ARGV if values @$a;
35925e80 398####
43b09ad7 399# 51 Anonymous arrays and hashes, and references to them
35925e80
RGS
400my $a = {};
401my $b = \{};
402my $c = [];
403my $d = \[];
9210de83
FR
404####
405# SKIP ?$] < 5.010 && "smartmatch and given/when not implemented on this Perl version"
43b09ad7 406# 52 implicit smartmatch in given/when
9210de83
FR
407given ('foo') {
408 when ('bar') { continue; }
409 when ($_ ~~ 'quux') { continue; }
410 default { 0; }
411}