This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Scan for expected and unwanted undef (libc) symbols.
[perl5.git] / t / porting / libperl.t
1 #!/usr/bin/perl -w
2
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 #
6 # Fail softly, expect things only on known platforms.
7 #
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
11 # the details).
12 #
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.
16 #
17 # Some terminology:
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
23 #     by the loader
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.
33
34 BEGIN {
35     chdir 't' if -d 't';
36     @INC = '../lib';
37     require "./test.pl";
38 }
39
40 use strict;
41
42 use Config;
43
44 if ($Config{cc} =~ /g\+\+/) {
45     # XXX Could use c++filt, maybe.
46     skip_all "on g++";
47 }
48
49 my $libperl_a;
50
51 for my $f (qw(../libperl.a libperl.a)) {
52   if (-f $f) {
53     $libperl_a = $f;
54     last;
55   }
56 }
57
58 unless (defined $libperl_a) {
59   skip_all "no libperl.a";
60 }
61
62 print "# \$^O = $^O\n";
63 print "# \$Config{cc} = $Config{cc}\n";
64 print "# libperl = $libperl_a\n";
65
66 my $nm;
67 my $nm_opt = '';
68 my $nm_style;
69
70 if ($^O eq 'linux') {
71     $nm = '/usr/bin/nm';
72     $nm_style = 'gnu';
73 } elsif ($^O eq 'darwin') {
74     $nm = '/usr/bin/nm';
75     $nm_style = '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.
80     $nm_opt = '-m';
81 }
82
83 unless (defined $nm) {
84   skip_all "no nm";
85 }
86
87 unless (defined $nm_style) {
88   skip_all "no nm style";
89 }
90
91 print "# nm = $nm\n";
92 print "# nm_style = $nm_style\n";
93 print "# nm_opt = $nm_opt\n";
94
95 unless (-x $nm) {
96     skip_all "no executable nm $nm";
97 }
98
99 if ($nm_style eq 'gnu') {
100     open(my $nm_fh, "$nm --version|") or
101         skip_all "nm failed: $!";
102     my $gnu_verified;
103     while (<$nm_fh>) {
104         if (/^GNU nm/) {
105             $gnu_verified = 1;
106             last;
107         }
108     }
109     unless ($gnu_verified) {
110         skip_all "no GNU nm";
111     }
112 }
113
114 my $nm_err_tmp = "libperl$$";
115
116 END {
117     # this is still executed when we skip_all above, avoid a warning
118     unlink $nm_err_tmp if $nm_err_tmp;
119 }
120
121 my $nm_fh;
122
123 if (@ARGV == 1) {
124     my $fake = shift @ARGV;
125     print "# Faking nm output from $fake\n";
126     if ($fake eq '-') {
127         open($nm_fh, "<&STDIN") or
128             skip_all "Duping STDIN failed: $!";
129     } else {
130         open($nm_fh, "<", $fake) or
131             skip_all "Opening '$fake' failed: $!";
132     }
133     undef $nm_err_tmp; # In this case there will be no nm errors.
134 } else {
135     open($nm_fh, "$nm $nm_opt $libperl_a 2>$nm_err_tmp |") or
136         skip_all "$nm $nm_opt $libperl_a failed: $!";
137 }
138
139 sub is_perlish_symbol {
140     $_[0] =~ /^(?:PL_|Perl|PerlIO)/;
141 }
142
143 sub nm_parse_gnu {
144     my $symbols = shift;
145     my $line = $_;
146     if (m{^(\w+\.o):$}) {
147         $symbols->{obj}{$1}++;
148         $symbols->{o} = $1;
149         return;
150     } else {
151         die "$0: undefined current object: $line"
152             unless defined $symbols->{o};
153         if (s/^[0-9a-f]{8}(?:[0-9a-f]{8})? //) {
154             if (/^[Rr] (\w+)$/) {
155                 $symbols->{data}{const}{$1}{$symbols->{o}}++;
156             } elsif (/^r .+$/) {
157                 # Skip local const.
158             } elsif (/^[Tti] (\w+)(\..+)?$/) {
159                 $symbols->{text}{$1}{$symbols->{o}}++;
160             } elsif (/^C (\w+)$/) {
161                 $symbols->{data}{common}{$1}{$symbols->{o}}++;
162             } elsif (/^[BbSs] (\w+)(\.\d+)?$/) {
163                 $symbols->{data}{bss}{$1}{$symbols->{o}}++;
164             } elsif (/^0{16} D _LIB_VERSION$/) {
165                 # Skip the _LIB_VERSION (not ours).
166             } elsif (/^[DdGg] (\w+)$/) {
167                 $symbols->{data}{data}{$1}{$symbols->{o}}++;
168             } elsif (/^. \.?(\w+)$/) {
169                 # Skip the unknown types.
170                 print "# Unknown type: $line ($symbols->{o})\n";
171             }
172             return;
173         } elsif (/^ {8}(?: {8})? U _?(\w+)$/) {
174             my ($symbol) = $1;
175             return if is_perlish_symbol($symbol);
176             $symbols->{undef}{$symbol}{$symbols->{o}}++;
177             return;
178         }
179     }
180     print "# Unexpected nm output '$line' ($symbols->{o})\n";
181 }
182
183 sub nm_parse_darwin {
184     my $symbols = shift;
185     my $line = $_;
186     if (m{^(?:\.\./)?libperl\.a\((\w+\.o)\):$}) {
187         $symbols->{obj}{$1}++;
188         $symbols->{o} = $1;
189         return;
190     } else {
191         die "$0: undefined current object: $line" unless defined $symbols->{o};
192         if (s/^[0-9a-f]{8}(?:[0-9a-f]{8})? //) {
193             if (/^\(__TEXT,__(?:const|cstring|literal\d+)\) (?:non-)?external _?(\w+)(\.\w+)?$/) {
194                 my ($symbol, $suffix) = ($1, $2);
195                 # Ignore function-local constants like
196                 # _Perl_av_extend_guts.oom_array_extend
197                 return if defined $suffix && /__TEXT,__const/;
198                 # Ignore the cstring unnamed strings.
199                 return if $symbol =~ /^L\.str\d+$/;
200                 $symbols->{data}{const}{$symbol}{$symbols->{o}}++;
201             } elsif (/^\(__TEXT,__text\) (?:non-)?external _(\w+)$/) {
202                 $symbols->{text}{$1}{$symbols->{o}}++;
203             } elsif (/^\(__DATA,__(const|data|bss|common)\) (?:non-)?external _(\w+)(\.\w+)?$/) {
204                 my ($dtype, $symbol, $suffix) = ($1, $2, $3);
205                 # Ignore function-local constants like
206                 # _Perl_pp_gmtime.dayname
207                 return if defined $suffix;
208                 $symbols->{data}{$dtype}{$symbol}{$symbols->{o}}++;
209             } elsif (/^\(__DATA,__const\) non-external _\.memset_pattern\d*$/) {
210                 # Skip this, whatever it is (some inlined leakage from
211                 # darwin libc?)
212             } elsif (/^\(__TEXT,__eh_frame/) {
213                 # Skip the eh_frame symbols.
214                 return;
215             } elsif (/^\(__\w+,__\w+\) /) {
216                 # Skip the unknown types.
217                 print "# Unknown type: $line ($symbols->{o})\n";
218             }
219             return;
220         } elsif (/^ {8}(?: {8})? \(undefined(?: \[lazy bound\])?\) external _?(.+)/) {
221             my ($symbol) = $1;
222             return if is_perlish_symbol($symbol);
223             $symbols->{undef}{$symbol}{$symbols->{o}}++;
224             return;
225         }
226     }
227     print "# Unexpected nm output '$line' ($symbols->{o})\n";
228 }
229
230 my $nm_parse;
231
232 if ($nm_style eq 'gnu') {
233     $nm_parse = \&nm_parse_gnu;
234 } elsif ($nm_style eq 'darwin') {
235     $nm_parse = \&nm_parse_darwin;
236 }
237
238 unless (defined $nm_parse) {
239     skip_all "no nm parser ($nm_style $nm_style, \$^O $^O)";
240 }
241
242 my %symbols;
243
244 while (<$nm_fh>) {
245     next if /^$/;
246     chomp;
247     $nm_parse->(\%symbols);
248 }
249
250 # use Data::Dumper; print Dumper(\%symbols);
251
252 if (keys %symbols == 0) {
253     skip_all "no symbols\n";
254 }
255
256 # These should always be true for everyone.
257
258 ok($symbols{obj}{'pp.o'}, "has object pp.o");
259 ok($symbols{text}{'Perl_peep'}, "has text Perl_peep");
260 ok($symbols{text}{'Perl_pp_uc'}{'pp.o'}, "has text Perl_pp_uc in pp.o");
261 ok(exists $symbols{data}{const}, "has data const symbols");
262 ok($symbols{data}{const}{PL_no_mem}{'globals.o'}, "has PL_no_mem");
263
264 my $DEBUGGING = $Config{ccflags} =~ /-DDEBUGGING/ ? 1 : 0;
265
266 my $GS  = $Config{ccflags} =~ /-DPERL_GLOBAL_STRUCT\b/ ? 1 : 0;
267 my $GSP = $Config{ccflags} =~ /-DPERL_GLOBAL_STRUCT_PRIVATE/ ? 1 : 0;
268
269 print "# GS  = $GS\n";
270 print "# GSP = $GSP\n";
271
272 my %data_symbols;
273
274 for my $dtype (sort keys %{$symbols{data}}) {
275     for my $symbol (sort keys %{$symbols{data}{$dtype}}) {
276         $data_symbols{$symbol}++;
277     }
278 }
279
280 # The following tests differ between vanilla vs $GSP or $GS.
281
282 if ($GSP) {
283     print "# -DPERL_GLOBAL_STRUCT_PRIVATE\n";
284     ok(!exists $data_symbols{PL_hash_seed}, "has no PL_hash_seed");
285     ok(!exists $data_symbols{PL_ppaddr}, "has no PL_ppaddr");
286
287     ok(! exists $symbols{data}{bss}, "has no data bss symbols");
288     ok(! exists $symbols{data}{data} ||
289             # clang with ASAN seems to add this symbol to every object file:
290             !grep($_ ne '__unnamed_1', keys %{$symbols{data}{data}}),
291         "has no data data symbols");
292     ok(! exists $symbols{data}{common}, "has no data common symbols");
293
294     # -DPERL_GLOBAL_STRUCT_PRIVATE should NOT have
295     # the extra text symbol for accessing the vars
296     # (as opposed to "just" -DPERL_GLOBAL_STRUCT)
297     ok(! exists $symbols{text}{Perl_GetVars}, "has no Perl_GetVars");
298 } elsif ($GS) {
299     print "# -DPERL_GLOBAL_STRUCT\n";
300     ok(!exists $data_symbols{PL_hash_seed}, "has no PL_hash_seed");
301     ok(!exists $data_symbols{PL_ppaddr}, "has no PL_ppaddr");
302
303     ok(! exists $symbols{data}{bss}, "has no data bss symbols");
304
305     # These PerlIO data symbols are left visible with
306     # -DPERL_GLOBAL_STRUCT (as opposed to -DPERL_GLOBAL_STRUCT_PRIVATE)
307     my @PerlIO =
308         qw(
309            PerlIO_byte
310            PerlIO_crlf
311            PerlIO_pending
312            PerlIO_perlio
313            PerlIO_raw
314            PerlIO_remove
315            PerlIO_stdio
316            PerlIO_unix
317            PerlIO_utf8
318           );
319
320     # PL_magic_vtables is const with -DPERL_GLOBAL_STRUCT_PRIVATE but
321     # otherwise not const -- because of SWIG which wants to modify
322     # the table.  Evil SWIG, eeevil.
323
324     # my_cxt_index is used with PERL_IMPLICIT_CONTEXT, which
325     # -DPERL_GLOBAL_STRUCT has turned on.
326     eq_array([sort keys %{$symbols{data}{data}}],
327              [sort('PL_VarsPtr',
328                    @PerlIO,
329                    'PL_magic_vtables',
330                    'my_cxt_index')],
331              "data data symbols");
332
333     # Only one data common symbol, our "supervariable".
334     eq_array([sort keys %{$symbols{data}{common}}],
335              ['PL_Vars'],
336              "data common symbols");
337
338     ok($symbols{data}{data}{PL_VarsPtr}{'globals.o'}, "has PL_VarsPtr");
339     ok($symbols{data}{common}{PL_Vars}{'globals.o'}, "has PL_Vars");
340
341     # -DPERL_GLOBAL_STRUCT has extra text symbol for accessing the vars.
342     ok($symbols{text}{Perl_GetVars}{'util.o'}, "has Perl_GetVars");
343 } else {
344     print "# neither -DPERL_GLOBAL_STRUCT nor -DPERL_GLOBAL_STRUCT_PRIVATE\n";
345
346     if ( !$symbols{data}{common} ) {
347         # This is likely because Perl was compiled with
348         # -Accflags="-fno-common"
349         $symbols{data}{common} = $symbols{data}{bss};
350     }
351
352     ok($symbols{data}{common}{PL_hash_seed}{'globals.o'}, "has PL_hash_seed");
353     ok($symbols{data}{data}{PL_ppaddr}{'globals.o'}, "has PL_ppaddr");
354
355     # None of the GLOBAL_STRUCT* business here.
356     ok(! exists $symbols{data}{data}{PL_VarsPtr}, "has no PL_VarsPtr");
357     ok(! exists $symbols{data}{common}{PL_Vars}, "has no PL_Vars");
358     ok(! exists $symbols{text}{Perl_GetVars}, "has no Perl_GetVars");
359 }
360
361 ok(keys %{$symbols{undef}}, "has undefined symbols");
362
363 my @good = qw(memchr memcmp memcpy chmod socket getenv sigaction sqrt time);
364 if ($Config{usedl}) {
365     push @good, 'dlopen';
366 }
367 for my $good (@good) {
368     my @o = exists $symbols{undef}{$good} ?
369         sort keys %{ $symbols{undef}{$good} } : ();
370     ok(@o, "uses $good (@o)");
371 }
372
373 my @bad = qw(gets strcpy strcat strncpy strncat sprintf vsprintf);
374 # XXX: add atoi() to @bad
375 for my $bad (@bad) {
376     my @o = exists $symbols{undef}{$bad} ?
377         sort keys %{ $symbols{undef}{$bad} } : ();
378     is(@o, 0, "uses no $bad (@o)");
379 }
380
381 if (defined $nm_err_tmp) {
382     if (open(my $nm_err_fh, $nm_err_tmp)) {
383         my $error;
384         while (<$nm_err_fh>) {
385             # OS X has weird error where nm warns about
386             # "no name list" but then outputs fine.
387             if (/nm: no name list/ && $^O eq 'darwin') {
388                 print "# $^O ignoring $nm output: $_";
389                 next;
390             }
391             warn "$0: Unexpected $nm error: $_";
392             $error++;
393         }
394         die "$0: Unexpected $nm errors\n" if $error;
395     } else {
396         warn "Failed to open '$nm_err_tmp': $!\n";
397     }
398 }
399
400 done_testing();