This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Patch by Salvador Fandiño to read the warning mask
[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 }
11}
12
13$| = 1;
14use warnings;
15use strict;
16use Config;
17
4ae52e81 18print "1..18\n";
87a42246
MS
19
20use B::Deparse;
21my $deparse = B::Deparse->new() or print "not ";
ad46c0be 22my $i=1;
d4a0c6f3 23print "ok " . $i++ . "\n";
ad46c0be 24
87a42246
MS
25
26# Tell B::Deparse about our ambient pragmas
27{ my ($hint_bits, $warning_bits);
8fa7688f
SF
28 # Note: there used to be ${^WARNING_BITS} here, instead of
29 # warnings::bits('all'), but this doesn't work, as ${^WARNING_BITS} is
30 # supposed to be the set of warnings this code has been compiled with, and
31 # later in this test we include modules that themselves use warnings::register
32 # (thus modyfing the warnings mask).
33 BEGIN { ($hint_bits, $warning_bits) = ($^H, warnings::bits('all')); }
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
MS
90
91# XXX ToDo - constsub that returns a reference
92#use constant cr => ['hello'];
93#my $string = "sub " . $deparse->coderef2text(\&cr);
94#my $val = (eval $string)->();
95#print "not " if ref($val) ne 'ARRAY' || $val->[0] ne 'hello';
d4a0c6f3 96#print "ok " . $i++ . "\n";
87a42246
MS
97
98my $a;
99my $Is_VMS = $^O eq 'VMS';
100my $Is_MacOS = $^O eq 'MacOS';
101
102my $path = join " ", map { qq["-I$_"] } @INC;
be708cc0 103$path .= " -MMac::err=unix" if $Is_MacOS;
87a42246
MS
104my $redir = $Is_MacOS ? "" : "2>&1";
105
d2bc402e 106$a = `$^X $path "-MO=Deparse" -anlwi.bak -e 1 $redir`;
e69a2255 107$a =~ s/-e syntax OK\n//g;
d2bc402e 108$a =~ s/.*possible typo.*\n//; # Remove warning line
87a42246
MS
109$a =~ s{\\340\\242}{\\s} if (ord("\\") == 224); # EBCDIC, cp 1047 or 037
110$a =~ s{\\274\\242}{\\s} if (ord("\\") == 188); # $^O eq 'posix-bc'
111$b = <<'EOF';
d2bc402e
RGS
112BEGIN { $^I = ".bak"; }
113BEGIN { $^W = 1; }
114BEGIN { $/ = "\n"; $\ = "\n"; }
87a42246
MS
115LINE: while (defined($_ = <ARGV>)) {
116 chomp $_;
14a55f98 117 our(@F) = split(" ", $_, 0);
87a42246
MS
118 '???';
119}
87a42246 120EOF
e69a2255
JH
121$b =~ s/(LINE:)/sub BEGIN {
122 'MacPerl'->bootstrap;
123 'OSA'->bootstrap;
124 'XL'->bootstrap;
125}
126$1/ if $Is_MacOS;
f99a63a2 127print "# [$a]\n\# vs expected\n# [$b]\nnot " if $a ne $b;
d4a0c6f3 128print "ok " . $i++ . "\n";
87a42246 129
ad46c0be 130__DATA__
14a55f98 131# 2
ad46c0be
RH
1321;
133####
14a55f98 134# 3
ad46c0be
RH
135{
136 no warnings;
137 '???';
138 2;
139}
140####
14a55f98 141# 4
ad46c0be
RH
142my $test;
143++$test and $test /= 2;
144>>>>
145my $test;
146$test /= 2 if ++$test;
147####
14a55f98 148# 5
ad46c0be
RH
149-((1, 2) x 2);
150####
14a55f98 151# 6
ad46c0be
RH
152{
153 my $test = sub : lvalue {
154 my $x;
155 }
156 ;
157}
158####
14a55f98 159# 7
ad46c0be
RH
160{
161 my $test = sub : method {
162 my $x;
163 }
164 ;
165}
166####
14a55f98 167# 8
ad46c0be
RH
168{
169 my $test = sub : locked method {
170 my $x;
171 }
172 ;
173}
174####
14a55f98 175# 9
87a42246 176{
ad46c0be 177 234;
f99a63a2 178}
ad46c0be
RH
179continue {
180 123;
87a42246 181}
ce4e655d 182####
14a55f98 183# 10
ce4e655d
RH
184my $x;
185print $main::x;
186####
14a55f98 187# 11
ce4e655d
RH
188my @x;
189print $main::x[1];
14a55f98
RH
190####
191# 12
192my %x;
193$x{warn()};
ad8caead
RGS
194####
195# 13
196my $foo;
197$_ .= <ARGV> . <$foo>;
cef22867
JH
198####
199# 14
200my $foo = "Ab\x{100}\200\x{200}\377Cd\000Ef\x{1000}\cA\x{2000}\cZ";
4ae52e81
RGS
201####
202# 15
203s/x/'y';/e;