This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
skip_all on darwin until nm peculiarities can be straighted out.
[perl5.git] / t / porting / libperl.t
CommitLineData
d92f47ae
JH
1#!/usr/bin/perl -w
2
3# Try opening libperl.a with nm, and verifying it has the kind of symbols
4# we expected. Fail softly, expect things only on known platforms.
5#
6# Also, if the rarely-used builds options -DPERL_GLOBAL_STRUCT or
7# -DPERL_GLOBAL_STRUCT_PRIVATE are used, verify that they did what
8# they were meant to do, hide the global variables (see perlguts for
9# the details).
10
11BEGIN {
12 chdir 't' if -d 't';
13 @INC = '../lib';
14 require "./test.pl";
15}
16
17use strict;
18
19use Config;
20
21if ($Config{cc} =~ /g\+\+/) {
22 # XXX Could use c++filt, maybe.
23 skip_all "on g++";
24}
25
26my $libperl_a;
27
28for my $f (qw(../libperl.a libperl.a)) {
29 if (-f $f) {
30 $libperl_a = $f;
31 last;
32 }
33}
34
35unless (defined $libperl_a) {
36 skip_all "no libperl.a";
37}
38
39print "# libperl = $libperl_a\n";
40
41my $nm;
42my $nm_opt = '';
43my $nm_style;
44
45if ($^O eq 'linux') {
46 $nm = '/usr/bin/nm';
47 $nm_style = 'gnu';
48} elsif ($^O eq 'darwin') {
49 $nm = '/usr/bin/nm';
50 $nm_style = 'darwin';
51 # With the -m option we get better information than the BSD-like
52 # default: with the default, a lot of symbols get dumped into 'S'
53 # or 's', for example one cannot tell the difference between const
54 # and non-const symbols.
55 $nm_opt = '-m';
56}
57
58unless (defined $nm) {
59 skip_all "no nm";
60}
61
62unless (defined $nm_style) {
63 skip_all "no nm style";
64}
65
66print "# nm = $nm\n";
67print "# nm_style = $nm_style\n";
68print "# nm_opt = $nm_opt\n";
69
70unless (-x $nm) {
71 skip_all "no executable nm $nm";
72}
73
74if ($nm_style eq 'gnu') {
75 open(my $nm_fh, "$nm --version|") or
76 skip_all "nm failed: $!";
77 my $gnu_verified;
78 while (<$nm_fh>) {
79 if (/^GNU nm/) {
80 $gnu_verified = 1;
81 last;
82 }
83 }
84 unless ($gnu_verified) {
f7bdd0be 85 skip_all "no GNU nm";
d92f47ae
JH
86 }
87}
88
ed0e322c
JK
89if ($^O eq 'darwin') {
90 skip_all 'nm peculiarities on darwin need study: RT #122267'
91}
92
b52baaa9
JH
93my $nm_err_tmp = "libperl$$";
94
95END {
f7bdd0be
TC
96 # this is still executed when we skip_all above, avoid a warning
97 unlink $nm_err_tmp if $nm_err_tmp;
b52baaa9
JH
98}
99
100open(my $nm_fh, "$nm $nm_opt $libperl_a 2>$nm_err_tmp |") or
d92f47ae
JH
101 skip_all "$nm $nm_opt $libperl_a failed: $!";
102
103sub nm_parse_gnu {
104 my $symbols = shift;
105 if (m{^(\w+\.o):$}) {
106 $symbols->{obj}{$1}++;
107 $symbols->{o} = $1;
108 } else {
109 die "$0: undefined current object: $_" unless defined $symbols->{o};
110 if (/^[0-9a-f]{16} [Rr] (\w+)$/) {
111 $symbols->{data}{const}{$1}{$symbols->{o}}++;
112 } elsif (/^[0-9a-f]{16} r .+$/) {
113 # Skip local const.
114 } elsif (/^[0-9a-f]{16} [Tti] (\w+)(\..+)?$/) {
115 $symbols->{text}{$1}{$symbols->{o}}++;
116 } elsif (/^[0-9a-f]{16} C (\w+)$/) {
117 $symbols->{data}{common}{$1}{$symbols->{o}}++;
118 } elsif (/^[0-9a-f]{16} [BbSs] (\w+)(\.\d+)?$/) {
119 $symbols->{data}{bss}{$1}{$symbols->{o}}++;
120 } elsif (/^0{16} D _LIB_VERSION$/) {
121 # Skip the _LIB_VERSION (not ours).
122 } elsif (/^[0-9a-f]{16} [DdGg] (\w+)$/) {
123 $symbols->{data}{data}{$1}{$symbols->{o}}++;
124 } elsif (/^ {16} U (\w+)$/) {
125 # Skip the undefined.
126 } elsif (/^[0-9a-f]{16} . \.?(\w+)$/) {
127 # Skip the unknown types.
128 print "# Unknown type: $_ ($symbols->{o})\n";
129 } else {
130 print "# Unexpected nm output '$_' ($symbols->{o})\n";
131 }
132 }
133}
134
135sub nm_parse_darwin {
136 my $symbols = shift;
137 if (m{^(?:\.\./)?libperl\.a\((\w+\.o)\):$}) {
138 $symbols->{obj}{$1}++;
139 $symbols->{o} = $1;
140 } else {
141 die "$0: undefined current object: $_" unless defined $symbols->{o};
142 if (/^[0-9a-f]{16} \(__TEXT,__(?:eh_frame|cstring)\) /) {
143 # Skip the eh_frame and cstring.
144 } elsif (/^[0-9a-f]{16} \(__TEXT,__(?:const|literal\d+)\) (?:non-)?external _?(\w+)(\.\w+)?$/) {
145 my ($symbol, $suffix) = ($1, $2);
146 # Ignore function-local constants like
147 # _Perl_av_extend_guts.oom_array_extend
148 return if defined $suffix && /__TEXT,__const/;
149 $symbols->{data}{const}{$symbol}{$symbols->{o}}++;
150 } elsif (/^[0-9a-f]{16} \(__TEXT,__text\) (?:non-)?external _(\w+)$/) {
151 $symbols->{text}{$1}{$symbols->{o}}++;
152 } elsif (/^[0-9a-f]{16} \(__DATA,__(const|data|bss|common)\) (?:non-)?external _(\w+)(\.\w+)?$/) {
153 my ($dtype, $symbol, $suffix) = ($1, $2, $3);
154 # Ignore function-local constants like
155 # _Perl_pp_gmtime.dayname
156 return if defined $suffix;
157 $symbols->{data}{$dtype}{$symbol}{$symbols->{o}}++;
158 } elsif (/^[0-9a-f]{16} \(__DATA,__const\) non-external _\.memset_pattern\d*$/) {
159 # Skip this, whatever it is (some inlined leakage from darwin libc?)
160 } elsif (/^ {16} \(undefined\) /) {
161 # Skip the undefined.
162 } elsif (/^[0-9a-f]{16} \(__\w+,__\w+\) /) {
163 # Skip the unknown types.
164 print "# Unknown type: $_ ($symbols->{o})\n";
165 } else {
166 print "# Unexpected nm output '$_' ($symbols->{o})\n";
167 }
168 }
169}
170
171my $nm_parse;
172
173if ($nm_style eq 'gnu') {
174 $nm_parse = \&nm_parse_gnu;
175} elsif ($nm_style eq 'darwin') {
176 $nm_parse = \&nm_parse_darwin;
177}
178
179unless (defined $nm_parse) {
180 skip_all "no nm parser";
181}
182
183my %symbols;
184
185while (<$nm_fh>) {
186 next if /^$/;
187 chomp;
188 $nm_parse->(\%symbols);
189}
190
191# use Data::Dumper; print Dumper(\%symbols);
192
193if (keys %symbols == 0) {
194 skip_all "no symbols\n";
195}
196
197# These should always be true for everyone.
198
199ok($symbols{obj}{'pp.o'}, "has object pp.o");
200ok($symbols{text}{'Perl_peep'}, "has text Perl_peep");
201ok($symbols{text}{'Perl_pp_uc'}{'pp.o'}, "has text Perl_pp_uc in pp.o");
202ok(exists $symbols{data}{const}, "has data const symbols");
203ok($symbols{data}{const}{PL_no_mem}{'globals.o'}, "has PL_no_mem");
204
205my $DEBUGGING = $Config{ccflags} =~ /-DDEBUGGING/ ? 1 : 0;
206
207my $GS = $Config{ccflags} =~ /-DPERL_GLOBAL_STRUCT\b/ ? 1 : 0;
208my $GSP = $Config{ccflags} =~ /-DPERL_GLOBAL_STRUCT_PRIVATE/ ? 1 : 0;
209
210print "# GS = $GS\n";
211print "# GSP = $GSP\n";
212
213my %data_symbols;
214
215for my $dtype (sort keys %{$symbols{data}}) {
216 for my $symbol (sort keys %{$symbols{data}{$dtype}}) {
217 $data_symbols{$symbol}++;
218 }
219}
220
221# Since we are deprived of Test::More.
222sub is_deeply {
223 my ($a, $b) = @_;
224 if (ref $a eq 'ARRAY' && ref $b eq 'ARRAY') {
225 if (@$a == @$b) {
226 for my $i (0..$#$a) {
227 unless ($a->[$i] eq $b->[$i]) {
228 printf("# LHS elem #%d '%s' ne RHS elem #%d '%s'\n",
229 $a->[$i], $b->[$i]);
230 return 0;
231 }
232 }
233 return 1;
234 } else {
235 printf("# LHS length %d, RHS length %d\n",
236 @$a, @$b);
237 return 0;
238 }
239 } else {
240 die "$0: Unexpcted: is_deeply $a $b\n";
241 }
242}
243
244# The following tests differ between vanilla vs $GSP or $GS.
245#
246# Some terminology:
247# - "text" symbols are code
248# - "data" symbols are data (duh), with subdivisions:
249# - "bss": (Block-Started-by-Symbol: originally from IBM assembler...),
250# uninitialized data, which often even doesn't exist in the object
251# file as such, only its size does, which is then created on demand
252# by the loader
253# - "const": initialized read-only data, like string literals
254# - "common": uninitialized data unless initialized...
255# (the full story is too long for here, see "man nm")
256# - "data": initialized read-write data
257# (somewhat confusingly below: "data data", but it makes code simpler)
258
259if ($GSP) {
260 print "# -DPERL_GLOBAL_STRUCT_PRIVATE\n";
261 ok(!exists $data_symbols{PL_hash_seed}, "has no PL_hash_seed");
262 ok(!exists $data_symbols{PL_ppaddr}, "has no PL_ppaddr");
263
264 ok(! exists $symbols{data}{bss}, "has no data bss symbols");
26443f8e
DM
265 ok(! exists $symbols{data}{data} ||
266 # clang with ASAN seems to add this symbol to every object file:
267 !grep($_ ne '__unnamed_1', keys %{$symbols{data}{data}}),
268 "has no data data symbols");
d92f47ae
JH
269 ok(! exists $symbols{data}{common}, "has no data common symbols");
270
271 # -DPERL_GLOBAL_STRUCT_PRIVATE should NOT have
272 # the extra text symbol for accessing the vars
273 # (as opposed to "just" -DPERL_GLOBAL_STRUCT)
274 ok(! exists $symbols{text}{Perl_GetVars}, "has no Perl_GetVars");
275} elsif ($GS) {
276 print "# -DPERL_GLOBAL_STRUCT\n";
277 ok(!exists $data_symbols{PL_hash_seed}, "has no PL_hash_seed");
278 ok(!exists $data_symbols{PL_ppaddr}, "has no PL_ppaddr");
279
280 ok(! exists $symbols{data}{bss}, "has no data bss symbols");
281
282 # These PerlIO data symbols are left visible with
283 # -DPERL_GLOBAL_STRUCT (as opposed to -DPERL_GLOBAL_STRUCT_PRIVATE)
284 my @PerlIO =
285 qw(
286 PerlIO_byte
287 PerlIO_crlf
288 PerlIO_pending
289 PerlIO_perlio
290 PerlIO_raw
291 PerlIO_remove
292 PerlIO_stdio
293 PerlIO_unix
294 PerlIO_utf8
295 );
296
297 # PL_magic_vtables is const with -DPERL_GLOBAL_STRUCT_PRIVATE but
298 # otherwise not const -- because of SWIG which wants to modify
299 # the table. Evil SWIG, eeevil.
300
301 # my_cxt_index is used with PERL_IMPLICIT_CONTEXT, which
302 # -DPERL_GLOBAL_STRUCT has turned on.
303 is_deeply([sort keys %{$symbols{data}{data}}],
304 [sort('PL_VarsPtr',
305 @PerlIO,
306 'PL_magic_vtables',
307 'my_cxt_index')],
308 "data data symbols");
309
310 # Only one data common symbol, our "supervariable".
311 is_deeply([sort keys %{$symbols{data}{common}}],
312 ['PL_Vars'],
313 "data common symbols");
314
315 ok($symbols{data}{data}{PL_VarsPtr}{'globals.o'}, "has PL_VarsPtr");
316 ok($symbols{data}{common}{PL_Vars}{'globals.o'}, "has PL_Vars");
317
318 # -DPERL_GLOBAL_STRUCT has extra text symbol for accessing the vars.
319 ok($symbols{text}{Perl_GetVars}{'util.o'}, "has Perl_GetVars");
320} else {
321 print "# neither -DPERL_GLOBAL_STRUCT nor -DPERL_GLOBAL_STRUCT_PRIVATE\n";
322
a9abea17
BF
323 if ( !$symbols{data}{common} ) {
324 # This is likely because Perl was compiled with
325 # -Accflags="-fno-common"
326 $symbols{data}{common} = $symbols{data}{bss};
327 }
328
d92f47ae
JH
329 ok($symbols{data}{common}{PL_hash_seed}{'globals.o'}, "has PL_hash_seed");
330 ok($symbols{data}{data}{PL_ppaddr}{'globals.o'}, "has PL_ppaddr");
331
332 # None of the GLOBAL_STRUCT* business here.
333 ok(! exists $symbols{data}{data}{PL_VarsPtr}, "has no PL_VarsPtr");
334 ok(! exists $symbols{data}{common}{PL_Vars}, "has no PL_Vars");
335 ok(! exists $symbols{text}{Perl_GetVars}, "has no Perl_GetVars");
336}
337
b52baaa9
JH
338if (open(my $nm_err_fh, $nm_err_tmp)) {
339 my $error;
340 while (<$nm_err_fh>) {
01444e81
JH
341 # OS X has weird error where nm warns about
342 # "no name list" but then outputs fine.
343 if (/nm: no name list/ && $^O eq 'darwin') {
b52baaa9
JH
344 print "# $^O ignoring $nm output: $_";
345 next;
346 }
347 warn "$0: Unexpected $nm error: $_";
348 $error++;
349 }
350 die "$0: Unexpected $nm errors\n" if $error;
351} else {
352 warn "Failed to open '$nm_err_tmp': $!\n";
353}
354
d92f47ae 355done_testing();