3 # Try opening libperl.a with nm, and verifying it has the kind of
4 # symbols we expect, and no symbols we should avoid.
6 # Fail softly, expect things only on known platforms.
8 # Also, if the rarely-used builds options -DPERL_GLOBAL_STRUCT or
9 # -DPERL_GLOBAL_STRUCT_PRIVATE are used, verify that they did what
10 # they were meant to do, hide the global variables (see perlguts for
13 # Debugging tip: nm output (this script's input) can be faked by
14 # giving one command line argument for this script: it should be
15 # either the filename to read, or "-" for STDIN.
18 # - "text" symbols are code
19 # - "data" symbols are data (duh), with subdivisions:
20 # - "bss": (Block-Started-by-Symbol: originally from IBM assembler...),
21 # uninitialized data, which often even doesn't exist in the object
22 # file as such, only its size does, which is then created on demand
24 # - "const": initialized read-only data, like string literals
25 # - "common": uninitialized data unless initialized...
26 # (the full story is too long for here, see "man nm")
27 # - "data": initialized read-write data
28 # (somewhat confusingly below: "data data", but it makes code simpler)
29 # - "undefined": external symbol referred to by an object,
30 # most likely a text symbol. Can be either a symbol defined by
31 # a Perl object file but referred to by other Perl object files,
32 # or a completely external symbol from libc, or other system libraries.
44 if ($Config{cc} =~ /g\+\+/) {
45 # XXX Could use c++filt, maybe.
51 for my $f (qw(../libperl.a libperl.a)) {
58 unless (defined $libperl_a) {
59 skip_all "no libperl.a";
62 print "# \$^O = $^O\n";
63 print "# \$Config{cc} = $Config{cc}\n";
64 print "# libperl = $libperl_a\n";
73 } elsif ($^O eq 'darwin') {
76 # With the -m option we get better information than the BSD-like
77 # default: with the default, a lot of symbols get dumped into 'S'
78 # or 's', for example one cannot tell the difference between const
79 # and non-const symbols.
83 unless (defined $nm) {
87 unless (defined $nm_style) {
88 skip_all "no nm style";
92 print "# nm_style = $nm_style\n";
93 print "# nm_opt = $nm_opt\n";
96 skip_all "no executable nm $nm";
99 if ($nm_style eq 'gnu') {
100 open(my $nm_fh, "$nm --version|") or
101 skip_all "nm failed: $!";
109 unless ($gnu_verified) {
110 skip_all "no GNU nm";
114 my $nm_err_tmp = "libperl$$";
117 # this is still executed when we skip_all above, avoid a warning
118 unlink $nm_err_tmp if $nm_err_tmp;
124 my $fake = shift @ARGV;
125 print "# Faking nm output from $fake\n";
127 open($nm_fh, "<&STDIN") or
128 skip_all "Duping STDIN failed: $!";
130 open($nm_fh, "<", $fake) or
131 skip_all "Opening '$fake' failed: $!";
133 undef $nm_err_tmp; # In this case there will be no nm errors.
135 open($nm_fh, "$nm $nm_opt $libperl_a 2>$nm_err_tmp |") or
136 skip_all "$nm $nm_opt $libperl_a failed: $!";
139 sub is_perlish_symbol {
140 $_[0] =~ /^(?:PL_|Perl|PerlIO)/;
146 if (m{^(\w+\.o):$}) {
148 $symbols->{obj}{$1}++;
152 die "$0: undefined current object: $line"
153 unless defined $symbols->{o};
154 # 64-bit systems have 16 hexdigits, 32-bit systems have 8.
155 if (s/^[0-9a-f]{8}(?:[0-9a-f]{8})? //) {
156 if (/^[Rr] (\w+)$/) {
157 # R: read only (const)
158 $symbols->{data}{const}{$1}{$symbols->{o}}++;
160 # Skip local const (read only).
161 } elsif (/^[Tti] (\w+)(\..+)?$/) {
162 $symbols->{text}{$1}{$symbols->{o}}++;
163 } elsif (/^C (\w+)$/) {
164 $symbols->{data}{common}{$1}{$symbols->{o}}++;
165 } elsif (/^[BbSs] (\w+)(\.\d+)?$/) {
166 # Bb: uninitialized data (bss)
167 # Ss: uninitialized data "for small objects"
168 $symbols->{data}{bss}{$1}{$symbols->{o}}++;
169 } elsif (/^0{16} D _LIB_VERSION$/) {
170 # Skip the _LIB_VERSION (not ours, probably libm)
171 } elsif (/^[DdGg] (\w+)$/) {
172 # Dd: initialized data
173 # Gg: initialized "for small objects"
174 $symbols->{data}{data}{$1}{$symbols->{o}}++;
175 } elsif (/^. \.?(\w+)$/) {
176 # Skip the unknown types.
177 print "# Unknown type: $line ($symbols->{o})\n";
180 } elsif (/^ {8}(?: {8})? U _?(\w+)$/) {
182 return if is_perlish_symbol($symbol);
183 $symbols->{undef}{$symbol}{$symbols->{o}}++;
187 print "# Unexpected nm output '$line' ($symbols->{o})\n";
190 sub nm_parse_darwin {
193 if (m{^(?:.+)?libperl\.a\((\w+\.o)\):$}) {
195 $symbols->{obj}{$1}++;
199 die "$0: undefined current object: $line" unless defined $symbols->{o};
200 # 64-bit systems have 16 hexdigits, 32-bit systems have 8.
201 if (s/^[0-9a-f]{8}(?:[0-9a-f]{8})? //) {
202 # String literals can live in different sections
203 # depending on the compiler and os release, assumedly
205 if (/^\(__TEXT,__(?:const|cstring|literal\d+)\) (?:non-)?external _?(\w+)(\.\w+)?$/) {
206 my ($symbol, $suffix) = ($1, $2);
207 # Ignore function-local constants like
208 # _Perl_av_extend_guts.oom_array_extend
209 return if defined $suffix && /__TEXT,__const/;
210 # Ignore the cstring unnamed strings.
211 return if $symbol =~ /^L\.str\d+$/;
212 $symbols->{data}{const}{$symbol}{$symbols->{o}}++;
213 } elsif (/^\(__TEXT,__text\) (?:non-)?external _(\w+)$/) {
214 $symbols->{text}{$1}{$symbols->{o}}++;
215 } elsif (/^\(__DATA,__(const|data|bss|common)\) (?:non-)?external _(\w+)(\.\w+)?$/) {
216 my ($dtype, $symbol, $suffix) = ($1, $2, $3);
217 # Ignore function-local constants like
218 # _Perl_pp_gmtime.dayname
219 return if defined $suffix;
220 $symbols->{data}{$dtype}{$symbol}{$symbols->{o}}++;
221 } elsif (/^\(__DATA,__const\) non-external _\.memset_pattern\d*$/) {
222 # Skip this, whatever it is (some inlined leakage from
224 } elsif (/^\(__TEXT,__eh_frame/) {
225 # Skip the eh_frame (exception handling) symbols.
227 } elsif (/^\(__\w+,__\w+\) /) {
228 # Skip the unknown types.
229 print "# Unknown type: $line ($symbols->{o})\n";
232 } elsif (/^ {8}(?: {8})? \(undefined(?: \[lazy bound\])?\) external _?(.+)/) {
233 # darwin/ppc marks most undefined text symbols
236 return if is_perlish_symbol($symbol);
237 $symbols->{undef}{$symbol}{$symbols->{o}}++;
241 print "# Unexpected nm output '$line' ($symbols->{o})\n";
246 if ($nm_style eq 'gnu') {
247 $nm_parse = \&nm_parse_gnu;
248 } elsif ($nm_style eq 'darwin') {
249 $nm_parse = \&nm_parse_darwin;
252 unless (defined $nm_parse) {
253 skip_all "no nm parser ($nm_style $nm_style, \$^O $^O)";
261 $nm_parse->(\%symbols);
264 # use Data::Dumper; print Dumper(\%symbols);
266 if (keys %symbols == 0) {
267 skip_all "no symbols\n";
270 # These should always be true for everyone.
272 ok($symbols{obj}{'pp.o'}, "has object pp.o");
273 ok($symbols{text}{'Perl_peep'}, "has text Perl_peep");
274 ok($symbols{text}{'Perl_pp_uc'}{'pp.o'}, "has text Perl_pp_uc in pp.o");
275 ok(exists $symbols{data}{const}, "has data const symbols");
276 ok($symbols{data}{const}{PL_no_mem}{'globals.o'}, "has PL_no_mem");
278 my $DEBUGGING = $Config{ccflags} =~ /-DDEBUGGING/ ? 1 : 0;
280 my $GS = $Config{ccflags} =~ /-DPERL_GLOBAL_STRUCT\b/ ? 1 : 0;
281 my $GSP = $Config{ccflags} =~ /-DPERL_GLOBAL_STRUCT_PRIVATE/ ? 1 : 0;
283 print "# GS = $GS\n";
284 print "# GSP = $GSP\n";
288 for my $dtype (sort keys %{$symbols{data}}) {
289 for my $symbol (sort keys %{$symbols{data}{$dtype}}) {
290 $data_symbols{$symbol}++;
294 # The following tests differ between vanilla vs $GSP or $GS.
297 print "# -DPERL_GLOBAL_STRUCT_PRIVATE\n";
298 ok(!exists $data_symbols{PL_hash_seed}, "has no PL_hash_seed");
299 ok(!exists $data_symbols{PL_ppaddr}, "has no PL_ppaddr");
301 ok(! exists $symbols{data}{bss}, "has no data bss symbols");
302 ok(! exists $symbols{data}{data} ||
303 # clang with ASAN seems to add this symbol to every object file:
304 !grep($_ ne '__unnamed_1', keys %{$symbols{data}{data}}),
305 "has no data data symbols");
306 ok(! exists $symbols{data}{common}, "has no data common symbols");
308 # -DPERL_GLOBAL_STRUCT_PRIVATE should NOT have
309 # the extra text symbol for accessing the vars
310 # (as opposed to "just" -DPERL_GLOBAL_STRUCT)
311 ok(! exists $symbols{text}{Perl_GetVars}, "has no Perl_GetVars");
313 print "# -DPERL_GLOBAL_STRUCT\n";
314 ok(!exists $data_symbols{PL_hash_seed}, "has no PL_hash_seed");
315 ok(!exists $data_symbols{PL_ppaddr}, "has no PL_ppaddr");
317 ok(! exists $symbols{data}{bss}, "has no data bss symbols");
319 # These PerlIO data symbols are left visible with
320 # -DPERL_GLOBAL_STRUCT (as opposed to -DPERL_GLOBAL_STRUCT_PRIVATE)
334 # PL_magic_vtables is const with -DPERL_GLOBAL_STRUCT_PRIVATE but
335 # otherwise not const -- because of SWIG which wants to modify
336 # the table. Evil SWIG, eeevil.
338 # my_cxt_index is used with PERL_IMPLICIT_CONTEXT, which
339 # -DPERL_GLOBAL_STRUCT has turned on.
340 eq_array([sort keys %{$symbols{data}{data}}],
345 "data data symbols");
347 # Only one data common symbol, our "supervariable".
348 eq_array([sort keys %{$symbols{data}{common}}],
350 "data common symbols");
352 ok($symbols{data}{data}{PL_VarsPtr}{'globals.o'}, "has PL_VarsPtr");
353 ok($symbols{data}{common}{PL_Vars}{'globals.o'}, "has PL_Vars");
355 # -DPERL_GLOBAL_STRUCT has extra text symbol for accessing the vars.
356 ok($symbols{text}{Perl_GetVars}{'util.o'}, "has Perl_GetVars");
358 print "# neither -DPERL_GLOBAL_STRUCT nor -DPERL_GLOBAL_STRUCT_PRIVATE\n";
360 if ( !$symbols{data}{common} ) {
361 # This is likely because Perl was compiled with
362 # -Accflags="-fno-common"
363 $symbols{data}{common} = $symbols{data}{bss};
366 ok($symbols{data}{common}{PL_hash_seed}{'globals.o'}, "has PL_hash_seed");
367 ok($symbols{data}{data}{PL_ppaddr}{'globals.o'}, "has PL_ppaddr");
369 # None of the GLOBAL_STRUCT* business here.
370 ok(! exists $symbols{data}{data}{PL_VarsPtr}, "has no PL_VarsPtr");
371 ok(! exists $symbols{data}{common}{PL_Vars}, "has no PL_Vars");
372 ok(! exists $symbols{text}{Perl_GetVars}, "has no Perl_GetVars");
375 ok(keys %{$symbols{undef}}, "has undefined symbols");
377 my @good = qw(memchr memcmp memcpy chmod socket getenv sigaction sqrt time);
378 if ($Config{usedl}) {
379 push @good, 'dlopen';
381 for my $good (@good) {
382 my @o = exists $symbols{undef}{$good} ?
383 sort keys %{ $symbols{undef}{$good} } : ();
384 ok(@o, "uses $good (@o)");
387 my @bad = qw(gets strcpy strcat strncpy strncat sprintf vsprintf);
388 # XXX: add atoi() to @bad
390 my @o = exists $symbols{undef}{$bad} ?
391 sort keys %{ $symbols{undef}{$bad} } : ();
392 is(@o, 0, "uses no $bad (@o)");
395 if (defined $nm_err_tmp) {
396 if (open(my $nm_err_fh, $nm_err_tmp)) {
398 while (<$nm_err_fh>) {
399 # OS X has weird error where nm warns about
400 # "no name list" but then outputs fine.
401 if (/nm: no name list/ && $^O eq 'darwin') {
402 print "# $^O ignoring $nm output: $_";
405 warn "$0: Unexpected $nm error: $_";
408 die "$0: Unexpected $nm errors\n" if $error;
410 warn "Failed to open '$nm_err_tmp': $!\n";