Commit | Line | Data |
---|---|---|
d92f47ae JH |
1 | #!/usr/bin/perl -w |
2 | ||
831ed035 JH |
3 | # Try opening libperl.a with nm, and verifying it has the kind of |
4 | # symbols we expect, and no symbols we should avoid. | |
5 | # | |
aab7f3d5 | 6 | # Fail softly, expect things only on known platforms: |
63b7eadb | 7 | # - linux, x86 only (ppc linux has odd symbol tables) |
aab7f3d5 JH |
8 | # - darwin (OS X), both x86 and ppc |
9 | # - freebsd | |
10 | # and on other platforms, and if things seem odd, just give up (skip_all). | |
d92f47ae JH |
11 | # |
12 | # Also, if the rarely-used builds options -DPERL_GLOBAL_STRUCT or | |
13 | # -DPERL_GLOBAL_STRUCT_PRIVATE are used, verify that they did what | |
14 | # they were meant to do, hide the global variables (see perlguts for | |
15 | # the details). | |
caea674c JH |
16 | # |
17 | # Debugging tip: nm output (this script's input) can be faked by | |
18 | # giving one command line argument for this script: it should be | |
88abe8fb JH |
19 | # either the filename to read, or "-" for STDIN. You can also append |
20 | # "@style" (where style is a supported nm style, like "gnu" or "darwin") | |
21 | # to this filename for "cross-parsing". | |
831ed035 JH |
22 | # |
23 | # Some terminology: | |
24 | # - "text" symbols are code | |
25 | # - "data" symbols are data (duh), with subdivisions: | |
26 | # - "bss": (Block-Started-by-Symbol: originally from IBM assembler...), | |
27 | # uninitialized data, which often even doesn't exist in the object | |
28 | # file as such, only its size does, which is then created on demand | |
29 | # by the loader | |
30 | # - "const": initialized read-only data, like string literals | |
31 | # - "common": uninitialized data unless initialized... | |
32 | # (the full story is too long for here, see "man nm") | |
33 | # - "data": initialized read-write data | |
34 | # (somewhat confusingly below: "data data", but it makes code simpler) | |
35 | # - "undefined": external symbol referred to by an object, | |
36 | # most likely a text symbol. Can be either a symbol defined by | |
37 | # a Perl object file but referred to by other Perl object files, | |
38 | # or a completely external symbol from libc, or other system libraries. | |
d92f47ae JH |
39 | |
40 | BEGIN { | |
41 | chdir 't' if -d 't'; | |
42 | @INC = '../lib'; | |
43 | require "./test.pl"; | |
44 | } | |
45 | ||
46 | use strict; | |
47 | ||
48 | use Config; | |
49 | ||
50 | if ($Config{cc} =~ /g\+\+/) { | |
51 | # XXX Could use c++filt, maybe. | |
52 | skip_all "on g++"; | |
53 | } | |
54 | ||
55 | my $libperl_a; | |
56 | ||
57 | for my $f (qw(../libperl.a libperl.a)) { | |
58 | if (-f $f) { | |
59 | $libperl_a = $f; | |
60 | last; | |
61 | } | |
62 | } | |
63 | ||
64 | unless (defined $libperl_a) { | |
65 | skip_all "no libperl.a"; | |
66 | } | |
67 | ||
cb498e56 | 68 | print "# \$^O = $^O\n"; |
63b7eadb | 69 | print "# \$Config{archname} = $Config{archname}\n"; |
cb498e56 | 70 | print "# \$Config{cc} = $Config{cc}\n"; |
d92f47ae JH |
71 | print "# libperl = $libperl_a\n"; |
72 | ||
73 | my $nm; | |
74 | my $nm_opt = ''; | |
75 | my $nm_style; | |
88abe8fb JH |
76 | my $nm_fh; |
77 | my $nm_err_tmp = "libperl$$"; | |
78 | ||
79 | END { | |
80 | # this is still executed when we skip_all above, avoid a warning | |
81 | unlink $nm_err_tmp if $nm_err_tmp; | |
82 | } | |
83 | ||
84 | my $fake_input; | |
85 | my $fake_style; | |
86 | ||
87 | if (@ARGV == 1) { | |
88 | $fake_input = shift @ARGV; | |
89 | print "# Faking nm output from $fake_input\n"; | |
90 | if ($fake_input =~ s/\@(.+)$//) { | |
91 | $fake_style = $1; | |
92 | print "# Faking nm style from $fake_style\n"; | |
aab7f3d5 JH |
93 | if ($fake_style eq 'gnu' || |
94 | $fake_style eq 'linux' || | |
95 | $fake_style eq 'freebsd') { | |
88abe8fb JH |
96 | $nm_style = 'gnu' |
97 | } elsif ($fake_style eq 'darwin' || $fake_style eq 'osx') { | |
98 | $nm_style = 'darwin' | |
99 | } else { | |
100 | die "$0: Unknown explicit nm style '$fake_style'\n"; | |
101 | } | |
102 | } | |
103 | } | |
104 | ||
105 | unless (defined $nm_style) { | |
106 | if ($^O eq 'linux') { | |
aab7f3d5 JH |
107 | # The 'gnu' style could be equally well be called 'bsd' style, |
108 | # since the output format of the GNU binutils nm is really BSD. | |
109 | $nm_style = 'gnu'; | |
110 | } elsif ($^O eq 'freebsd') { | |
88abe8fb JH |
111 | $nm_style = 'gnu'; |
112 | } elsif ($^O eq 'darwin') { | |
113 | $nm_style = 'darwin'; | |
114 | } | |
115 | } | |
d92f47ae | 116 | |
88abe8fb JH |
117 | if (defined $nm_style) { |
118 | if ($nm_style eq 'gnu') { | |
119 | $nm = '/usr/bin/nm'; | |
120 | } elsif ($nm_style eq 'darwin') { | |
121 | $nm = '/usr/bin/nm'; | |
122 | # With the -m option we get better information than the BSD-like | |
123 | # default: with the default, a lot of symbols get dumped into 'S' | |
124 | # or 's', for example one cannot tell the difference between const | |
125 | # and non-const data symbols. | |
126 | $nm_opt = '-m'; | |
127 | } else { | |
128 | die "$0: Unexpected nm style '$nm_style'\n"; | |
129 | } | |
d92f47ae JH |
130 | } |
131 | ||
a1b6fca3 | 132 | if ($^O eq 'linux' && $Config{archname} !~ /^(?:x|i6)86/) { |
63b7eadb JH |
133 | # For example in ppc most (but not all!) code symbols are placed |
134 | # in 'D' (data), not in ' T '. We cannot work under such conditions. | |
135 | skip_all "linux but archname $Config{archname} not x86*"; | |
136 | } | |
137 | ||
d92f47ae JH |
138 | unless (defined $nm) { |
139 | skip_all "no nm"; | |
140 | } | |
141 | ||
142 | unless (defined $nm_style) { | |
143 | skip_all "no nm style"; | |
144 | } | |
145 | ||
146 | print "# nm = $nm\n"; | |
147 | print "# nm_style = $nm_style\n"; | |
148 | print "# nm_opt = $nm_opt\n"; | |
149 | ||
150 | unless (-x $nm) { | |
151 | skip_all "no executable nm $nm"; | |
152 | } | |
153 | ||
88abe8fb JH |
154 | if ($nm_style eq 'gnu' && !defined $fake_style) { |
155 | open(my $gnu_verify, "$nm --version|") or | |
d92f47ae JH |
156 | skip_all "nm failed: $!"; |
157 | my $gnu_verified; | |
88abe8fb | 158 | while (<$gnu_verify>) { |
d92f47ae JH |
159 | if (/^GNU nm/) { |
160 | $gnu_verified = 1; | |
161 | last; | |
162 | } | |
163 | } | |
164 | unless ($gnu_verified) { | |
f7bdd0be | 165 | skip_all "no GNU nm"; |
d92f47ae JH |
166 | } |
167 | } | |
168 | ||
88abe8fb JH |
169 | if (defined $fake_input) { |
170 | if ($fake_input eq '-') { | |
caea674c JH |
171 | open($nm_fh, "<&STDIN") or |
172 | skip_all "Duping STDIN failed: $!"; | |
173 | } else { | |
88abe8fb JH |
174 | open($nm_fh, "<", $fake_input) or |
175 | skip_all "Opening '$fake_input' failed: $!"; | |
caea674c JH |
176 | } |
177 | undef $nm_err_tmp; # In this case there will be no nm errors. | |
178 | } else { | |
1ee983f5 | 179 | print qq{# command: "$nm $nm_opt $libperl_a 2>$nm_err_tmp |"\n}; |
caea674c JH |
180 | open($nm_fh, "$nm $nm_opt $libperl_a 2>$nm_err_tmp |") or |
181 | skip_all "$nm $nm_opt $libperl_a failed: $!"; | |
182 | } | |
831ed035 JH |
183 | |
184 | sub is_perlish_symbol { | |
185 | $_[0] =~ /^(?:PL_|Perl|PerlIO)/; | |
186 | } | |
187 | ||
88abe8fb JH |
188 | # XXX Implement "internal test" for this script (option -t?) |
189 | # to verify that the parsing does what it's intended to. | |
190 | ||
d92f47ae JH |
191 | sub nm_parse_gnu { |
192 | my $symbols = shift; | |
7c616f70 | 193 | my $line = $_; |
d92f47ae | 194 | if (m{^(\w+\.o):$}) { |
68472ab1 | 195 | # object file name |
d92f47ae JH |
196 | $symbols->{obj}{$1}++; |
197 | $symbols->{o} = $1; | |
7c616f70 | 198 | return; |
d92f47ae | 199 | } else { |
7c616f70 JH |
200 | die "$0: undefined current object: $line" |
201 | unless defined $symbols->{o}; | |
68472ab1 | 202 | # 64-bit systems have 16 hexdigits, 32-bit systems have 8. |
7c616f70 JH |
203 | if (s/^[0-9a-f]{8}(?:[0-9a-f]{8})? //) { |
204 | if (/^[Rr] (\w+)$/) { | |
68472ab1 | 205 | # R: read only (const) |
7c616f70 JH |
206 | $symbols->{data}{const}{$1}{$symbols->{o}}++; |
207 | } elsif (/^r .+$/) { | |
68472ab1 | 208 | # Skip local const (read only). |
3faa8758 JH |
209 | } elsif (/^([Tti]) (\w+)(\..+)?$/) { |
210 | $symbols->{text}{$2}{$symbols->{o}}{$1}++; | |
7c616f70 JH |
211 | } elsif (/^C (\w+)$/) { |
212 | $symbols->{data}{common}{$1}{$symbols->{o}}++; | |
213 | } elsif (/^[BbSs] (\w+)(\.\d+)?$/) { | |
68472ab1 JH |
214 | # Bb: uninitialized data (bss) |
215 | # Ss: uninitialized data "for small objects" | |
7c616f70 | 216 | $symbols->{data}{bss}{$1}{$symbols->{o}}++; |
4613f3c1 | 217 | } elsif (/^D _LIB_VERSION$/) { |
68472ab1 | 218 | # Skip the _LIB_VERSION (not ours, probably libm) |
7c616f70 | 219 | } elsif (/^[DdGg] (\w+)$/) { |
68472ab1 JH |
220 | # Dd: initialized data |
221 | # Gg: initialized "for small objects" | |
7c616f70 JH |
222 | $symbols->{data}{data}{$1}{$symbols->{o}}++; |
223 | } elsif (/^. \.?(\w+)$/) { | |
224 | # Skip the unknown types. | |
225 | print "# Unknown type: $line ($symbols->{o})\n"; | |
226 | } | |
227 | return; | |
831ed035 JH |
228 | } elsif (/^ {8}(?: {8})? U _?(\w+)$/) { |
229 | my ($symbol) = $1; | |
230 | return if is_perlish_symbol($symbol); | |
231 | $symbols->{undef}{$symbol}{$symbols->{o}}++; | |
7c616f70 | 232 | return; |
d92f47ae JH |
233 | } |
234 | } | |
7c616f70 | 235 | print "# Unexpected nm output '$line' ($symbols->{o})\n"; |
d92f47ae JH |
236 | } |
237 | ||
238 | sub nm_parse_darwin { | |
239 | my $symbols = shift; | |
7c616f70 | 240 | my $line = $_; |
68472ab1 JH |
241 | if (m{^(?:.+)?libperl\.a\((\w+\.o)\):$}) { |
242 | # object file name | |
d92f47ae JH |
243 | $symbols->{obj}{$1}++; |
244 | $symbols->{o} = $1; | |
7c616f70 | 245 | return; |
d92f47ae | 246 | } else { |
7c616f70 | 247 | die "$0: undefined current object: $line" unless defined $symbols->{o}; |
68472ab1 | 248 | # 64-bit systems have 16 hexdigits, 32-bit systems have 8. |
7c616f70 | 249 | if (s/^[0-9a-f]{8}(?:[0-9a-f]{8})? //) { |
68472ab1 JH |
250 | # String literals can live in different sections |
251 | # depending on the compiler and os release, assumedly | |
252 | # also linker flags. | |
dc882775 | 253 | if (/^\(__TEXT,__(?:const|(?:asan_)?cstring|literal\d+)\) (?:non-)?external _?(\w+)(\.\w+)?$/) { |
7c616f70 JH |
254 | my ($symbol, $suffix) = ($1, $2); |
255 | # Ignore function-local constants like | |
256 | # _Perl_av_extend_guts.oom_array_extend | |
257 | return if defined $suffix && /__TEXT,__const/; | |
6d1ca00b JH |
258 | # Ignore the cstring unnamed strings. |
259 | return if $symbol =~ /^L\.str\d+$/; | |
7c616f70 | 260 | $symbols->{data}{const}{$symbol}{$symbols->{o}}++; |
3faa8758 JH |
261 | } elsif (/^\(__TEXT,__text\) ((?:non-)?external) _(\w+)$/) { |
262 | my ($exp, $sym) = ($1, $2); | |
263 | $symbols->{text}{$sym}{$symbols->{o}}{$exp =~ /^non/ ? 't' : 'T'}++; | |
de36638a | 264 | } elsif (/^\(__DATA,__\w*?(const|data|bss|common)\w*\) (?:non-)?external _?(\w+)(\.\w+)?$/) { |
7c616f70 JH |
265 | my ($dtype, $symbol, $suffix) = ($1, $2, $3); |
266 | # Ignore function-local constants like | |
267 | # _Perl_pp_gmtime.dayname | |
268 | return if defined $suffix; | |
269 | $symbols->{data}{$dtype}{$symbol}{$symbols->{o}}++; | |
270 | } elsif (/^\(__DATA,__const\) non-external _\.memset_pattern\d*$/) { | |
271 | # Skip this, whatever it is (some inlined leakage from | |
272 | # darwin libc?) | |
6d1ca00b | 273 | } elsif (/^\(__TEXT,__eh_frame/) { |
68472ab1 | 274 | # Skip the eh_frame (exception handling) symbols. |
6d1ca00b | 275 | return; |
7c616f70 JH |
276 | } elsif (/^\(__\w+,__\w+\) /) { |
277 | # Skip the unknown types. | |
278 | print "# Unknown type: $line ($symbols->{o})\n"; | |
279 | } | |
280 | return; | |
831ed035 | 281 | } elsif (/^ {8}(?: {8})? \(undefined(?: \[lazy bound\])?\) external _?(.+)/) { |
68472ab1 JH |
282 | # darwin/ppc marks most undefined text symbols |
283 | # as "[lazy bound]". | |
18d04e70 | 284 | my ($symbol) = $1 =~ s/\$UNIX2003\z//r; |
831ed035 JH |
285 | return if is_perlish_symbol($symbol); |
286 | $symbols->{undef}{$symbol}{$symbols->{o}}++; | |
7c616f70 | 287 | return; |
d92f47ae JH |
288 | } |
289 | } | |
7c616f70 | 290 | print "# Unexpected nm output '$line' ($symbols->{o})\n"; |
d92f47ae JH |
291 | } |
292 | ||
293 | my $nm_parse; | |
294 | ||
295 | if ($nm_style eq 'gnu') { | |
296 | $nm_parse = \&nm_parse_gnu; | |
297 | } elsif ($nm_style eq 'darwin') { | |
298 | $nm_parse = \&nm_parse_darwin; | |
299 | } | |
300 | ||
301 | unless (defined $nm_parse) { | |
cb498e56 | 302 | skip_all "no nm parser ($nm_style $nm_style, \$^O $^O)"; |
d92f47ae JH |
303 | } |
304 | ||
305 | my %symbols; | |
306 | ||
307 | while (<$nm_fh>) { | |
308 | next if /^$/; | |
309 | chomp; | |
310 | $nm_parse->(\%symbols); | |
311 | } | |
312 | ||
313 | # use Data::Dumper; print Dumper(\%symbols); | |
314 | ||
2c93157d JH |
315 | # Something went awfully wrong. Wrong nm? Wrong options? |
316 | unless (keys %symbols) { | |
d92f47ae JH |
317 | skip_all "no symbols\n"; |
318 | } | |
2c93157d JH |
319 | unless (exists $symbols{text}) { |
320 | skip_all "no text symbols\n"; | |
321 | } | |
d92f47ae JH |
322 | |
323 | # These should always be true for everyone. | |
324 | ||
325 | ok($symbols{obj}{'pp.o'}, "has object pp.o"); | |
326 | ok($symbols{text}{'Perl_peep'}, "has text Perl_peep"); | |
327 | ok($symbols{text}{'Perl_pp_uc'}{'pp.o'}, "has text Perl_pp_uc in pp.o"); | |
328 | ok(exists $symbols{data}{const}, "has data const symbols"); | |
329 | ok($symbols{data}{const}{PL_no_mem}{'globals.o'}, "has PL_no_mem"); | |
330 | ||
d92f47ae JH |
331 | my $GS = $Config{ccflags} =~ /-DPERL_GLOBAL_STRUCT\b/ ? 1 : 0; |
332 | my $GSP = $Config{ccflags} =~ /-DPERL_GLOBAL_STRUCT_PRIVATE/ ? 1 : 0; | |
d88a9086 | 333 | my $nocommon = $Config{ccflags} =~ /-fno-common/ ? 1 : 0; |
d92f47ae JH |
334 | |
335 | print "# GS = $GS\n"; | |
336 | print "# GSP = $GSP\n"; | |
d88a9086 | 337 | print "# nocommon = $nocommon\n"; |
d92f47ae JH |
338 | |
339 | my %data_symbols; | |
340 | ||
341 | for my $dtype (sort keys %{$symbols{data}}) { | |
342 | for my $symbol (sort keys %{$symbols{data}{$dtype}}) { | |
343 | $data_symbols{$symbol}++; | |
344 | } | |
345 | } | |
346 | ||
d92f47ae | 347 | # The following tests differ between vanilla vs $GSP or $GS. |
d92f47ae JH |
348 | |
349 | if ($GSP) { | |
350 | print "# -DPERL_GLOBAL_STRUCT_PRIVATE\n"; | |
351 | ok(!exists $data_symbols{PL_hash_seed}, "has no PL_hash_seed"); | |
352 | ok(!exists $data_symbols{PL_ppaddr}, "has no PL_ppaddr"); | |
353 | ||
1ee983f5 DM |
354 | ok(! exists $symbols{data}{bss}, "has no data bss symbols") |
355 | or do { | |
356 | my $bad = "BSS entries (there are supposed to be none):\n"; | |
357 | $bad .= " bss sym: $_\n" for sort keys %{$symbols{data}{bss}}; | |
358 | diag($bad); | |
359 | }; | |
360 | ||
26443f8e DM |
361 | ok(! exists $symbols{data}{data} || |
362 | # clang with ASAN seems to add this symbol to every object file: | |
363 | !grep($_ ne '__unnamed_1', keys %{$symbols{data}{data}}), | |
a5555695 DM |
364 | "has no data data symbols") |
365 | or do { | |
366 | my $bad = "DATA entries (there are supposed to be none):\n"; | |
367 | $bad .= " data sym: $_\n" for sort keys %{$symbols{data}{data}}; | |
368 | diag($bad); | |
369 | }; | |
370 | ||
371 | ok(! exists $symbols{data}{common}, "has no data common symbols") | |
372 | or do { | |
373 | my $bad = "COMMON entries (there are supposed to be none):\n"; | |
374 | $bad .= " common sym: $_\n" for sort keys %{$symbols{data}{common}}; | |
375 | diag($bad); | |
376 | }; | |
d92f47ae JH |
377 | |
378 | # -DPERL_GLOBAL_STRUCT_PRIVATE should NOT have | |
379 | # the extra text symbol for accessing the vars | |
380 | # (as opposed to "just" -DPERL_GLOBAL_STRUCT) | |
381 | ok(! exists $symbols{text}{Perl_GetVars}, "has no Perl_GetVars"); | |
382 | } elsif ($GS) { | |
383 | print "# -DPERL_GLOBAL_STRUCT\n"; | |
384 | ok(!exists $data_symbols{PL_hash_seed}, "has no PL_hash_seed"); | |
385 | ok(!exists $data_symbols{PL_ppaddr}, "has no PL_ppaddr"); | |
386 | ||
d88a9086 DM |
387 | if ($nocommon) { |
388 | $symbols{data}{common} = $symbols{data}{bss}; | |
389 | delete $symbols{data}{bss}; | |
390 | } | |
391 | ||
1ee983f5 DM |
392 | ok(! exists $symbols{data}{bss}, "has no data bss symbols") |
393 | or do { | |
394 | my $bad = "BSS entries (there are supposed to be none):\n"; | |
395 | $bad .= " bss sym: $_\n" for sort keys %{$symbols{data}{bss}}; | |
396 | diag($bad); | |
397 | }; | |
398 | ||
d92f47ae JH |
399 | |
400 | # These PerlIO data symbols are left visible with | |
401 | # -DPERL_GLOBAL_STRUCT (as opposed to -DPERL_GLOBAL_STRUCT_PRIVATE) | |
402 | my @PerlIO = | |
403 | qw( | |
404 | PerlIO_byte | |
405 | PerlIO_crlf | |
406 | PerlIO_pending | |
407 | PerlIO_perlio | |
408 | PerlIO_raw | |
409 | PerlIO_remove | |
410 | PerlIO_stdio | |
411 | PerlIO_unix | |
412 | PerlIO_utf8 | |
413 | ); | |
414 | ||
415 | # PL_magic_vtables is const with -DPERL_GLOBAL_STRUCT_PRIVATE but | |
416 | # otherwise not const -- because of SWIG which wants to modify | |
417 | # the table. Evil SWIG, eeevil. | |
418 | ||
419 | # my_cxt_index is used with PERL_IMPLICIT_CONTEXT, which | |
420 | # -DPERL_GLOBAL_STRUCT has turned on. | |
99a0b65c JH |
421 | eq_array([sort keys %{$symbols{data}{data}}], |
422 | [sort('PL_VarsPtr', | |
423 | @PerlIO, | |
424 | 'PL_magic_vtables', | |
425 | 'my_cxt_index')], | |
426 | "data data symbols"); | |
d92f47ae JH |
427 | |
428 | # Only one data common symbol, our "supervariable". | |
99a0b65c JH |
429 | eq_array([sort keys %{$symbols{data}{common}}], |
430 | ['PL_Vars'], | |
431 | "data common symbols"); | |
d92f47ae JH |
432 | |
433 | ok($symbols{data}{data}{PL_VarsPtr}{'globals.o'}, "has PL_VarsPtr"); | |
434 | ok($symbols{data}{common}{PL_Vars}{'globals.o'}, "has PL_Vars"); | |
435 | ||
436 | # -DPERL_GLOBAL_STRUCT has extra text symbol for accessing the vars. | |
437 | ok($symbols{text}{Perl_GetVars}{'util.o'}, "has Perl_GetVars"); | |
438 | } else { | |
439 | print "# neither -DPERL_GLOBAL_STRUCT nor -DPERL_GLOBAL_STRUCT_PRIVATE\n"; | |
440 | ||
a9abea17 | 441 | if ( !$symbols{data}{common} ) { |
831ed035 | 442 | # This is likely because Perl was compiled with |
a9abea17 BF |
443 | # -Accflags="-fno-common" |
444 | $symbols{data}{common} = $symbols{data}{bss}; | |
445 | } | |
831ed035 | 446 | |
d92f47ae JH |
447 | ok($symbols{data}{common}{PL_hash_seed}{'globals.o'}, "has PL_hash_seed"); |
448 | ok($symbols{data}{data}{PL_ppaddr}{'globals.o'}, "has PL_ppaddr"); | |
449 | ||
450 | # None of the GLOBAL_STRUCT* business here. | |
451 | ok(! exists $symbols{data}{data}{PL_VarsPtr}, "has no PL_VarsPtr"); | |
452 | ok(! exists $symbols{data}{common}{PL_Vars}, "has no PL_Vars"); | |
453 | ok(! exists $symbols{text}{Perl_GetVars}, "has no Perl_GetVars"); | |
454 | } | |
455 | ||
182bc989 JH |
456 | # See the comments in the beginning for what "undefined symbols" |
457 | # really means. We *should* have many of those, that is a good thing. | |
831ed035 JH |
458 | ok(keys %{$symbols{undef}}, "has undefined symbols"); |
459 | ||
182bc989 JH |
460 | # There are certain symbols we expect to see. |
461 | ||
0fa5dd23 JH |
462 | # chmod, socket, getenv, sigaction, exp, time are system/library |
463 | # calls that should each see at least one use. exp can be expl | |
9be194d5 | 464 | # if so configured. |
182bc989 | 465 | my %expected = ( |
182bc989 JH |
466 | chmod => undef, # There is no Configure symbol for chmod. |
467 | socket => 'd_socket', | |
468 | getenv => undef, # There is no Configure symbol for getenv, | |
469 | sigaction => 'd_sigaction', | |
470 | time => 'd_time', | |
471 | ); | |
472 | ||
57ae61ef | 473 | if ($Config{uselongdouble} && $Config{longdblsize} > $Config{doublesize}) { |
84e6cb05 JH |
474 | $expected{expl} = undef; # There is no Configure symbol for expl. |
475 | } elsif ($Config{usequadmath}) { | |
476 | $expected{expq} = undef; # There is no Configure symbol for expq. | |
182bc989 | 477 | } else { |
0fa5dd23 | 478 | $expected{exp} = undef; # There is no Configure symbol for exp. |
182bc989 | 479 | } |
1671bb9e JH |
480 | |
481 | # DynaLoader will use dlopen, unless we are building static, | |
93e77b8c | 482 | # and it is used in the platforms we are supporting in this test. |
182bc989 JH |
483 | if ($Config{usedl} ) { |
484 | $expected{dlopen} = 'd_dlopen'; | |
831ed035 | 485 | } |
1671bb9e | 486 | |
182bc989 JH |
487 | for my $symbol (sort keys %expected) { |
488 | if (defined $expected{$symbol} && !$Config{$expected{$symbol}}) { | |
489 | SKIP: { | |
490 | skip("no $symbol"); | |
491 | } | |
492 | next; | |
493 | } | |
494 | my @o = exists $symbols{undef}{$symbol} ? | |
495 | sort keys %{ $symbols{undef}{$symbol} } : (); | |
93e77b8c | 496 | ok(@o, "uses $symbol (@o)"); |
831ed035 JH |
497 | } |
498 | ||
182bc989 | 499 | # There are certain symbols we expect NOT to see. |
446b89af | 500 | # |
31e62fa1 JH |
501 | # gets is horribly unsafe. |
502 | # | |
446b89af JH |
503 | # fgets should not be used (Perl has its own API, sv_gets), |
504 | # even without perlio. | |
31e62fa1 JH |
505 | # |
506 | # tmpfile is unsafe. | |
507 | # | |
182bc989 | 508 | # strcat, strcpy, strncat, strncpy are unsafe. |
31e62fa1 JH |
509 | # |
510 | # sprintf and vsprintf should not be used because | |
511 | # Perl has its own safer and more portable implementations. | |
512 | # (One exception: for certain floating point outputs | |
182bc989 | 513 | # the native sprintf is still used in some platforms, see below.) |
31e62fa1 | 514 | # |
a7941017 | 515 | # atoi has unsafe and undefined failure modes, and is affected by locale. |
26065e6c | 516 | # Its cousins include atol and atoll. |
31e62fa1 | 517 | # |
68419f9c | 518 | # strtol and strtoul are affected by locale. |
26065e6c | 519 | # Cousins include strtoq. |
68419f9c | 520 | # |
6c1246d3 JH |
521 | # system should not be used, use pp_system or my_popen. |
522 | # | |
182bc989 JH |
523 | |
524 | my %unexpected; | |
525 | ||
6c1246d3 JH |
526 | for my $str (qw(system)) { |
527 | $unexpected{$str} = "d_$str"; | |
528 | } | |
529 | ||
182bc989 JH |
530 | for my $stdio (qw(gets fgets tmpfile sprintf vsprintf)) { |
531 | $unexpected{$stdio} = undef; # No Configure symbol for these. | |
532 | } | |
533 | for my $str (qw(strcat strcpy strncat strncpy)) { | |
534 | $unexpected{$str} = undef; # No Configure symbol for these. | |
535 | } | |
68419f9c | 536 | |
a7941017 | 537 | $unexpected{atoi} = undef; # No Configure symbol for atoi. |
26065e6c | 538 | $unexpected{atol} = undef; # No Configure symbol for atol. |
182bc989 | 539 | |
26065e6c | 540 | for my $str (qw(atoll strtol strtoul strtoq)) { |
68419f9c JH |
541 | $unexpected{$str} = "d_$str"; |
542 | } | |
543 | ||
182bc989 JH |
544 | for my $symbol (sort keys %unexpected) { |
545 | if (defined $unexpected{$symbol} && !$Config{$unexpected{$symbol}}) { | |
546 | SKIP: { | |
547 | skip("no $symbol"); | |
548 | } | |
549 | next; | |
550 | } | |
551 | my @o = exists $symbols{undef}{$symbol} ? | |
552 | sort keys %{ $symbols{undef}{$symbol} } : (); | |
aab7f3d5 JH |
553 | # While sprintf() is bad in the general case, |
554 | # some platforms implement Gconvert via sprintf, in sv.o. | |
182bc989 | 555 | if ($symbol eq 'sprintf' && |
aab7f3d5 JH |
556 | $Config{d_Gconvert} =~ /^sprintf/ && |
557 | @o == 1 && $o[0] eq 'sv.o') { | |
558 | SKIP: { | |
559 | skip("uses sprintf for Gconvert in sv.o"); | |
560 | } | |
561 | } else { | |
182bc989 | 562 | is(@o, 0, "uses no $symbol (@o)"); |
aab7f3d5 | 563 | } |
831ed035 JH |
564 | } |
565 | ||
3faa8758 JH |
566 | # Check that any text symbols named S_ are not exported. |
567 | my $export_S_prefix = 0; | |
568 | for my $t (sort grep { /^S_/ } keys %{$symbols{text}}) { | |
569 | for my $o (sort keys %{$symbols{text}{$t}}) { | |
570 | if (exists $symbols{text}{$t}{$o}{T}) { | |
571 | fail($t, "$t exported from $o"); | |
572 | $export_S_prefix++; | |
573 | } | |
574 | } | |
575 | } | |
576 | is($export_S_prefix, 0, "no S_ exports"); | |
577 | ||
caea674c JH |
578 | if (defined $nm_err_tmp) { |
579 | if (open(my $nm_err_fh, $nm_err_tmp)) { | |
580 | my $error; | |
581 | while (<$nm_err_fh>) { | |
582 | # OS X has weird error where nm warns about | |
583 | # "no name list" but then outputs fine. | |
d74b131b N |
584 | if ( $^O eq 'darwin' ) { |
585 | if (/nm: no name list/ || /^no symbols$/ ) { | |
586 | print "# $^O ignoring $nm output: $_"; | |
587 | next; | |
588 | } | |
caea674c JH |
589 | } |
590 | warn "$0: Unexpected $nm error: $_"; | |
591 | $error++; | |
b52baaa9 | 592 | } |
caea674c JH |
593 | die "$0: Unexpected $nm errors\n" if $error; |
594 | } else { | |
595 | warn "Failed to open '$nm_err_tmp': $!\n"; | |
b52baaa9 | 596 | } |
b52baaa9 JH |
597 | } |
598 | ||
d92f47ae | 599 | done_testing(); |