This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Confused by "#if &__GNUC_PREREQ (2,97)"
[perl5.git] / t / lib / b.t
CommitLineData
ccc418af
GS
1#!./perl
2
3BEGIN {
4 chdir 't' if -d 't';
1b026014
NIS
5 if ($^O eq 'MacOS') {
6 @INC = qw(: ::lib ::macos:lib);
7 } else {
8 @INC = '.';
9 push @INC, '../lib';
db5fd395 10 }
ccc418af
GS
11}
12
13$| = 1;
14use warnings;
15use strict;
16use Config;
17
fc674faa 18print "1..19\n";
ccc418af
GS
19
20my $test = 1;
21
22sub ok { print "ok $test\n"; $test++ }
23
24use B::Deparse;
25my $deparse = B::Deparse->new() or print "not ";
26ok;
27
08c6f5ec
RH
28# Tell B::Deparse about our ambient pragmas
29{ my ($hint_bits, $warning_bits);
30 BEGIN {($hint_bits, $warning_bits) = ($^H, ${^WARNING_BITS})}
31 $deparse->ambient_pragmas (
32 hint_bits => $hint_bits,
33 warning_bits => $warning_bits,
34 '$[' => 0 + $[
35 );
36}
37
ccc418af
GS
38print "not " if "{\n 1;\n}" ne $deparse->coderef2text(sub {1});
39ok;
40
41print "not " if "{\n '???';\n 2;\n}" ne
42 $deparse->coderef2text(sub {1;2});
43ok;
44
45print "not " if "{\n \$test /= 2 if ++\$test;\n}" ne
46 $deparse->coderef2text(sub {++$test and $test/=2;});
47ok;
f70490b9
NIS
48
49print "not " if "{\n -((1, 2) x 2);\n}" ne
50 $deparse->coderef2text(sub {-((1,2)x2)});
51ok;
52
9b86dfa2
SC
53{
54my $a = <<'EOF';
55{
56 $test = sub : lvalue {
78f9721b 57 my $x;
9b86dfa2
SC
58 }
59 ;
60}
61EOF
62chomp $a;
78f9721b 63print "not " if $deparse->coderef2text(sub{$test = sub : lvalue{my $x}}) ne $a;
9b86dfa2
SC
64ok;
65
66$a =~ s/lvalue/method/;
78f9721b 67print "not " if $deparse->coderef2text(sub{$test = sub : method{my $x}}) ne $a;
9b86dfa2
SC
68ok;
69
70$a =~ s/method/locked method/;
78f9721b 71print "not " if $deparse->coderef2text(sub{$test = sub : method locked {my $x}})
9b86dfa2
SC
72 ne $a;
73ok;
74}
ccc418af 75
de3f1649
JT
76print "not " if (eval "sub ".$deparse->coderef2text(sub () { 42 }))->() != 42;
77ok;
78
79use constant 'c', 'stuff';
80print "not " if (eval "sub ".$deparse->coderef2text(\&c))->() ne 'stuff';
81ok;
82
fc674faa
JH
83$a = 0;
84print "not " if "{\n (-1) ** \$a;\n}"
85 ne $deparse->coderef2text(sub{(-1) ** $a });
86ok;
87
de3f1649
JT
88# XXX ToDo - constsub that returns a reference
89#use constant cr => ['hello'];
90#my $string = "sub " . $deparse->coderef2text(\&cr);
91#my $val = (eval $string)->();
92#print "not " if ref($val) ne 'ARRAY' || $val->[0] ne 'hello';
93#ok;
94
885a8af1
JH
95my $a;
96my $Is_VMS = $^O eq 'VMS';
db5fd395
CN
97my $Is_MacOS = $^O eq 'MacOS';
98
99my $path = join " ", map { qq["-I$_"] } @INC;
100my $redir = $Is_MacOS ? "" : "2>&1";
101
102$a = `$^X $path "-MO=Deparse" -anle 1 $redir`;
5fb4d820 103$a =~ s/-e syntax OK\n//g;
bd145f00
PP
104$a =~ s{\\340\\242}{\\s} if (ord("\\") == 224); # EBCDIC, cp 1047 or 037
105$a =~ s{\\274\\242}{\\s} if (ord("\\") == 188); # $^O eq 'posix-bc'
ccc418af 106$b = <<'EOF';
ccc418af
GS
107
108LINE: while (defined($_ = <ARGV>)) {
109 chomp $_;
fee7e838 110 @F = split(" ", $_, 0);
58cccf98 111 '???';
ccc418af 112}
ccc418af
GS
113
114EOF
5fb4d820 115print "# [$a]\n\# vs\n# [$b]\nnot " if $a ne $b;
ccc418af
GS
116ok;
117
db5fd395 118$a = `$^X $path "-MO=Debug" -e 1 $redir`;
ccc418af
GS
119print "not " unless $a =~
120/\bLISTOP\b.*\bOP\b.*\bCOP\b.*\bOP\b/s;
121ok;
122
db5fd395 123$a = `$^X $path "-MO=Terse" -e 1 $redir`;
ccc418af 124print "not " unless $a =~
f72d64f0 125/\bLISTOP\b.*leave.*\n OP\b.*enter.*\n COP\b.*nextstate.*\n OP\b.*null/s;
ccc418af
GS
126ok;
127
db5fd395 128$a = `$^X $path "-MO=Terse" -ane "s/foo/bar/" $redir`;
ccc418af
GS
129$a =~ s/\(0x[^)]+\)//g;
130$a =~ s/\[[^\]]+\]//g;
131$a =~ s/-e syntax OK//;
132$a =~ s/[^a-z ]+//g;
133$a =~ s/\s+/ /g;
b2ec7025 134$a =~ s/\b(s|foo|bar|ullsv)\b\s?//g;
ccc418af
GS
135$a =~ s/^\s+//;
136$a =~ s/\s+$//;
208edb77
MG
137my $is_thread = $Config{use5005threads} && $Config{use5005threads} eq 'define';
138if ($is_thread) {
cfe9256d
JH
139 $b=<<EOF;
140leave enter nextstate label leaveloop enterloop null and defined null
141threadsv readline gv lineseq nextstate aassign null pushmark split pushre
142threadsv const null pushmark rvav gv nextstate subst const unstack nextstate
143EOF
144} else {
145 $b=<<EOF;
ccc418af
GS
146leave enter nextstate label leaveloop enterloop null and defined null
147null gvsv readline gv lineseq nextstate aassign null pushmark split pushre
cfe9256d 148null gvsv const null pushmark rvav gv nextstate subst const unstack nextstate
ccc418af 149EOF
cfe9256d 150}
ccc418af
GS
151$b=~s/\n/ /g;$b=~s/\s+/ /g;
152$b =~ s/\s+$//;
cfe9256d 153print "# [$a]\n# vs\n# [$b]\nnot " if $a ne $b;
ccc418af
GS
154ok;
155
db5fd395 156chomp($a = `$^X $path "-MB::Stash" "-Mwarnings" -e1`);
ccc418af 157$a = join ',', sort split /,/, $a;
7d3b96bb 158$a =~ s/-u(PerlIO|open)(?:::\w+)?,//g if defined $Config{'useperlio'} and $Config{'useperlio'} eq 'define';
754a99e1
GS
159$a =~ s/-uWin32,// if $^O eq 'MSWin32';
160$a =~ s/-u(Cwd|File|File::Copy|OS2),//g if $^O eq 'os2';
5d129265 161$a =~ s/-uCwd,// if $^O eq 'cygwin';
f3ff050f
JH
162if ($Config{static_ext} eq ' ') {
163 $b = '-uCarp,-uCarp::Heavy,-uDB,-uExporter,-uExporter::Heavy,-uattributes,'
1b026014 164 . '-umain,-ustrict,-uutf8,-uwarnings';
e5befd65
PP
165 if (ord('A') == 193) { # EBCDIC sort order is qw(a A) not qw(A a)
166 $b = join ',', sort split /,/, $b;
167 }
f3ff050f
JH
168 print "# [$a] vs [$b]\nnot " if $a ne $b;
169 ok;
170} else {
171 print "ok $test # skipped: one or more static extensions\n"; $test++;
172}
ccc418af 173
208edb77 174if ($is_thread) {
cfe9256d
JH
175 print "# use5005threads: test $test skipped\n";
176} else {
db5fd395 177 $a = `$^X $path "-MO=Showlex" -e "my %one" $redir`;
bd145f00
PP
178 if (ord('A') != 193) { # ASCIIish
179 print "# [$a]\nnot " unless $a =~ /sv_undef.*PVNV.*%one.*sv_undef.*HV/s;
1b026014 180 }
bd145f00
PP
181 else { # EBCDICish C<1: PVNV (0x1a7ede34) "%\226\225\205">
182 print "# [$a]\nnot " unless $a =~ /sv_undef.*PVNV.*%\\[0-9].*sv_undef.*HV/s;
183 }
885a8af1 184}
ccc418af 185ok;
1e1dbab6
SC
186
187# Bug 20001204.07
188{
189my $foo = $deparse->coderef2text(sub { { 234; }});
190# Constants don't get optimised here.
191print "not " unless $foo =~ /{.*{.*234;.*}.*}/sm;
192ok;
193$foo = $deparse->coderef2text(sub { { 234; } continue { 123; } });
1b026014 194print "not " unless $foo =~ /{.*{.*234;.*}.*continue.*{.*123.*}/sm;
1e1dbab6
SC
195ok;
196}