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