This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
In FreeBSD memcmp symbol can disappear.
[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 # - linux
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).
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).
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
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".
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.
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
68 print "# \$^O = $^O\n";
69 print "# \$Config{cc} = $Config{cc}\n";
70 print "# libperl = $libperl_a\n";
71
72 my $nm;
73 my $nm_opt = '';
74 my $nm_style;
75 my $nm_fh;
76 my $nm_err_tmp = "libperl$$";
77
78 END {
79     # this is still executed when we skip_all above, avoid a warning
80     unlink $nm_err_tmp if $nm_err_tmp;
81 }
82
83 my $fake_input;
84 my $fake_style;
85
86 if (@ARGV == 1) {
87     $fake_input = shift @ARGV;
88     print "# Faking nm output from $fake_input\n";
89     if ($fake_input =~ s/\@(.+)$//) {
90         $fake_style = $1;
91         print "# Faking nm style from $fake_style\n";
92         if ($fake_style eq 'gnu' ||
93             $fake_style eq 'linux' ||
94             $fake_style eq 'freebsd') {
95             $nm_style = 'gnu'
96         } elsif ($fake_style eq 'darwin' || $fake_style eq 'osx') {
97             $nm_style = 'darwin'
98         } else {
99             die "$0: Unknown explicit nm style '$fake_style'\n";
100         }
101     }
102 }
103
104 unless (defined $nm_style) {
105     if ($^O eq 'linux') {
106         # The 'gnu' style could be equally well be called 'bsd' style,
107         # since the output format of the GNU binutils nm is really BSD.
108         $nm_style = 'gnu';
109     } elsif ($^O eq 'freebsd') {
110         $nm_style = 'gnu';
111     } elsif ($^O eq 'darwin') {
112         $nm_style = 'darwin';
113     }
114 }
115
116 if (defined $nm_style) {
117     if ($nm_style eq 'gnu') {
118         $nm = '/usr/bin/nm';
119     } elsif ($nm_style eq 'darwin') {
120         $nm = '/usr/bin/nm';
121         # With the -m option we get better information than the BSD-like
122         # default: with the default, a lot of symbols get dumped into 'S'
123         # or 's', for example one cannot tell the difference between const
124         # and non-const data symbols.
125         $nm_opt = '-m';
126     } else {
127         die "$0: Unexpected nm style '$nm_style'\n";
128     }
129 }
130
131 unless (defined $nm) {
132   skip_all "no nm";
133 }
134
135 unless (defined $nm_style) {
136   skip_all "no nm style";
137 }
138
139 print "# nm = $nm\n";
140 print "# nm_style = $nm_style\n";
141 print "# nm_opt = $nm_opt\n";
142
143 unless (-x $nm) {
144     skip_all "no executable nm $nm";
145 }
146
147 if ($nm_style eq 'gnu' && !defined $fake_style) {
148     open(my $gnu_verify, "$nm --version|") or
149         skip_all "nm failed: $!";
150     my $gnu_verified;
151     while (<$gnu_verify>) {
152         if (/^GNU nm/) {
153             $gnu_verified = 1;
154             last;
155         }
156     }
157     unless ($gnu_verified) {
158         skip_all "no GNU nm";
159     }
160 }
161
162 if (defined $fake_input) {
163     if ($fake_input eq '-') {
164         open($nm_fh, "<&STDIN") or
165             skip_all "Duping STDIN failed: $!";
166     } else {
167         open($nm_fh, "<", $fake_input) or
168             skip_all "Opening '$fake_input' failed: $!";
169     }
170     undef $nm_err_tmp; # In this case there will be no nm errors.
171 } else {
172     open($nm_fh, "$nm $nm_opt $libperl_a 2>$nm_err_tmp |") or
173         skip_all "$nm $nm_opt $libperl_a failed: $!";
174 }
175
176 sub is_perlish_symbol {
177     $_[0] =~ /^(?:PL_|Perl|PerlIO)/;
178 }
179
180 # XXX Implement "internal test" for this script (option -t?)
181 # to verify that the parsing does what it's intended to.
182
183 sub nm_parse_gnu {
184     my $symbols = shift;
185     my $line = $_;
186     if (m{^(\w+\.o):$}) {
187         # object file name
188         $symbols->{obj}{$1}++;
189         $symbols->{o} = $1;
190         return;
191     } else {
192         die "$0: undefined current object: $line"
193             unless defined $symbols->{o};
194         # 64-bit systems have 16 hexdigits, 32-bit systems have 8.
195         if (s/^[0-9a-f]{8}(?:[0-9a-f]{8})? //) {
196             if (/^[Rr] (\w+)$/) {
197                 # R: read only (const)
198                 $symbols->{data}{const}{$1}{$symbols->{o}}++;
199             } elsif (/^r .+$/) {
200                 # Skip local const (read only).
201             } elsif (/^[Tti] (\w+)(\..+)?$/) {
202                 $symbols->{text}{$1}{$symbols->{o}}++;
203             } elsif (/^C (\w+)$/) {
204                 $symbols->{data}{common}{$1}{$symbols->{o}}++;
205             } elsif (/^[BbSs] (\w+)(\.\d+)?$/) {
206                 # Bb: uninitialized data (bss)
207                 # Ss: uninitialized data "for small objects"
208                 $symbols->{data}{bss}{$1}{$symbols->{o}}++;
209             } elsif (/^0{16} D _LIB_VERSION$/) {
210                 # Skip the _LIB_VERSION (not ours, probably libm)
211             } elsif (/^[DdGg] (\w+)$/) {
212                 # Dd: initialized data
213                 # Gg: initialized "for small objects"
214                 $symbols->{data}{data}{$1}{$symbols->{o}}++;
215             } elsif (/^. \.?(\w+)$/) {
216                 # Skip the unknown types.
217                 print "# Unknown type: $line ($symbols->{o})\n";
218             }
219             return;
220         } elsif (/^ {8}(?: {8})? U _?(\w+)$/) {
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 sub nm_parse_darwin {
231     my $symbols = shift;
232     my $line = $_;
233     if (m{^(?:.+)?libperl\.a\((\w+\.o)\):$}) {
234         # object file name
235         $symbols->{obj}{$1}++;
236         $symbols->{o} = $1;
237         return;
238     } else {
239         die "$0: undefined current object: $line" unless defined $symbols->{o};
240         # 64-bit systems have 16 hexdigits, 32-bit systems have 8.
241         if (s/^[0-9a-f]{8}(?:[0-9a-f]{8})? //) {
242             # String literals can live in different sections
243             # depending on the compiler and os release, assumedly
244             # also linker flags.
245             if (/^\(__TEXT,__(?:const|cstring|literal\d+)\) (?:non-)?external _?(\w+)(\.\w+)?$/) {
246                 my ($symbol, $suffix) = ($1, $2);
247                 # Ignore function-local constants like
248                 # _Perl_av_extend_guts.oom_array_extend
249                 return if defined $suffix && /__TEXT,__const/;
250                 # Ignore the cstring unnamed strings.
251                 return if $symbol =~ /^L\.str\d+$/;
252                 $symbols->{data}{const}{$symbol}{$symbols->{o}}++;
253             } elsif (/^\(__TEXT,__text\) (?:non-)?external _(\w+)$/) {
254                 $symbols->{text}{$1}{$symbols->{o}}++;
255             } elsif (/^\(__DATA,__(const|data|bss|common)\) (?:non-)?external _(\w+)(\.\w+)?$/) {
256                 my ($dtype, $symbol, $suffix) = ($1, $2, $3);
257                 # Ignore function-local constants like
258                 # _Perl_pp_gmtime.dayname
259                 return if defined $suffix;
260                 $symbols->{data}{$dtype}{$symbol}{$symbols->{o}}++;
261             } elsif (/^\(__DATA,__const\) non-external _\.memset_pattern\d*$/) {
262                 # Skip this, whatever it is (some inlined leakage from
263                 # darwin libc?)
264             } elsif (/^\(__TEXT,__eh_frame/) {
265                 # Skip the eh_frame (exception handling) symbols.
266                 return;
267             } elsif (/^\(__\w+,__\w+\) /) {
268                 # Skip the unknown types.
269                 print "# Unknown type: $line ($symbols->{o})\n";
270             }
271             return;
272         } elsif (/^ {8}(?: {8})? \(undefined(?: \[lazy bound\])?\) external _?(.+)/) {
273             # darwin/ppc marks most undefined text symbols
274             # as "[lazy bound]".
275             my ($symbol) = $1;
276             return if is_perlish_symbol($symbol);
277             $symbols->{undef}{$symbol}{$symbols->{o}}++;
278             return;
279         }
280     }
281     print "# Unexpected nm output '$line' ($symbols->{o})\n";
282 }
283
284 my $nm_parse;
285
286 if ($nm_style eq 'gnu') {
287     $nm_parse = \&nm_parse_gnu;
288 } elsif ($nm_style eq 'darwin') {
289     $nm_parse = \&nm_parse_darwin;
290 }
291
292 unless (defined $nm_parse) {
293     skip_all "no nm parser ($nm_style $nm_style, \$^O $^O)";
294 }
295
296 my %symbols;
297
298 while (<$nm_fh>) {
299     next if /^$/;
300     chomp;
301     $nm_parse->(\%symbols);
302 }
303
304 # use Data::Dumper; print Dumper(\%symbols);
305
306 if (keys %symbols == 0) {
307     skip_all "no symbols\n";
308 }
309
310 # These should always be true for everyone.
311
312 ok($symbols{obj}{'pp.o'}, "has object pp.o");
313 ok($symbols{text}{'Perl_peep'}, "has text Perl_peep");
314 ok($symbols{text}{'Perl_pp_uc'}{'pp.o'}, "has text Perl_pp_uc in pp.o");
315 ok(exists $symbols{data}{const}, "has data const symbols");
316 ok($symbols{data}{const}{PL_no_mem}{'globals.o'}, "has PL_no_mem");
317
318 my $DEBUGGING = $Config{ccflags} =~ /-DDEBUGGING/ ? 1 : 0;
319
320 my $GS  = $Config{ccflags} =~ /-DPERL_GLOBAL_STRUCT\b/ ? 1 : 0;
321 my $GSP = $Config{ccflags} =~ /-DPERL_GLOBAL_STRUCT_PRIVATE/ ? 1 : 0;
322
323 print "# GS  = $GS\n";
324 print "# GSP = $GSP\n";
325
326 my %data_symbols;
327
328 for my $dtype (sort keys %{$symbols{data}}) {
329     for my $symbol (sort keys %{$symbols{data}{$dtype}}) {
330         $data_symbols{$symbol}++;
331     }
332 }
333
334 # The following tests differ between vanilla vs $GSP or $GS.
335
336 if ($GSP) {
337     print "# -DPERL_GLOBAL_STRUCT_PRIVATE\n";
338     ok(!exists $data_symbols{PL_hash_seed}, "has no PL_hash_seed");
339     ok(!exists $data_symbols{PL_ppaddr}, "has no PL_ppaddr");
340
341     ok(! exists $symbols{data}{bss}, "has no data bss symbols");
342     ok(! exists $symbols{data}{data} ||
343             # clang with ASAN seems to add this symbol to every object file:
344             !grep($_ ne '__unnamed_1', keys %{$symbols{data}{data}}),
345         "has no data data symbols");
346     ok(! exists $symbols{data}{common}, "has no data common symbols");
347
348     # -DPERL_GLOBAL_STRUCT_PRIVATE should NOT have
349     # the extra text symbol for accessing the vars
350     # (as opposed to "just" -DPERL_GLOBAL_STRUCT)
351     ok(! exists $symbols{text}{Perl_GetVars}, "has no Perl_GetVars");
352 } elsif ($GS) {
353     print "# -DPERL_GLOBAL_STRUCT\n";
354     ok(!exists $data_symbols{PL_hash_seed}, "has no PL_hash_seed");
355     ok(!exists $data_symbols{PL_ppaddr}, "has no PL_ppaddr");
356
357     ok(! exists $symbols{data}{bss}, "has no data bss symbols");
358
359     # These PerlIO data symbols are left visible with
360     # -DPERL_GLOBAL_STRUCT (as opposed to -DPERL_GLOBAL_STRUCT_PRIVATE)
361     my @PerlIO =
362         qw(
363            PerlIO_byte
364            PerlIO_crlf
365            PerlIO_pending
366            PerlIO_perlio
367            PerlIO_raw
368            PerlIO_remove
369            PerlIO_stdio
370            PerlIO_unix
371            PerlIO_utf8
372           );
373
374     # PL_magic_vtables is const with -DPERL_GLOBAL_STRUCT_PRIVATE but
375     # otherwise not const -- because of SWIG which wants to modify
376     # the table.  Evil SWIG, eeevil.
377
378     # my_cxt_index is used with PERL_IMPLICIT_CONTEXT, which
379     # -DPERL_GLOBAL_STRUCT has turned on.
380     eq_array([sort keys %{$symbols{data}{data}}],
381              [sort('PL_VarsPtr',
382                    @PerlIO,
383                    'PL_magic_vtables',
384                    'my_cxt_index')],
385              "data data symbols");
386
387     # Only one data common symbol, our "supervariable".
388     eq_array([sort keys %{$symbols{data}{common}}],
389              ['PL_Vars'],
390              "data common symbols");
391
392     ok($symbols{data}{data}{PL_VarsPtr}{'globals.o'}, "has PL_VarsPtr");
393     ok($symbols{data}{common}{PL_Vars}{'globals.o'}, "has PL_Vars");
394
395     # -DPERL_GLOBAL_STRUCT has extra text symbol for accessing the vars.
396     ok($symbols{text}{Perl_GetVars}{'util.o'}, "has Perl_GetVars");
397 } else {
398     print "# neither -DPERL_GLOBAL_STRUCT nor -DPERL_GLOBAL_STRUCT_PRIVATE\n";
399
400     if ( !$symbols{data}{common} ) {
401         # This is likely because Perl was compiled with
402         # -Accflags="-fno-common"
403         $symbols{data}{common} = $symbols{data}{bss};
404     }
405
406     ok($symbols{data}{common}{PL_hash_seed}{'globals.o'}, "has PL_hash_seed");
407     ok($symbols{data}{data}{PL_ppaddr}{'globals.o'}, "has PL_ppaddr");
408
409     # None of the GLOBAL_STRUCT* business here.
410     ok(! exists $symbols{data}{data}{PL_VarsPtr}, "has no PL_VarsPtr");
411     ok(! exists $symbols{data}{common}{PL_Vars}, "has no PL_Vars");
412     ok(! exists $symbols{text}{Perl_GetVars}, "has no Perl_GetVars");
413 }
414
415 # See the comments in the beginning for what "undefined symbols"
416 # really means.  We *should* have many of those, that is a good thing.
417 ok(keys %{$symbols{undef}}, "has undefined symbols");
418
419 # There are certain symbols we expect to see.
420
421 # memchr, memcmp, memcpy should be used all over the place.
422 #
423 # chmod, socket, getenv, sigaction, sqrt, time are system/library
424 # calls that should each see at least one use. sqrt can be sqrtl
425 # if so configured.
426 my %expected = (
427     memchr => 'd_memchr',
428     memcmp => 'd_memcmp',
429     memcpy => 'd_memcpy',
430     chmod  => undef, # There is no Configure symbol for chmod.
431     socket => 'd_socket',
432     getenv => undef, # There is no Configure symbol for getenv,
433     sigaction => 'd_sigaction',
434     time   => 'd_time',
435     );
436
437 if ($Config{uselongdouble} && $Config{d_longdbl}) {
438     $expected{sqrtl} = 'd_sqrtl';
439 } else {
440     $expected{sqrt} = undef; # There is no Configure symbol for sqrt.
441 }
442
443 # DynaLoader will use dlopen, unless we are building static,
444 # and in the platforms we are supporting in this test.
445 if ($Config{usedl} ) {
446     $expected{dlopen} = 'd_dlopen';
447 }
448
449 for my $symbol (sort keys %expected) {
450     if (defined $expected{$symbol} && !$Config{$expected{$symbol}}) {
451       SKIP: {
452         skip("no $symbol");
453       }
454       next;
455     }
456     my @o = exists $symbols{undef}{$symbol} ?
457         sort keys %{ $symbols{undef}{$symbol} } : ();
458     # In some FreeBSD versions memcmp disappears (compiler inlining?).
459     if (($^O eq 'freebsd' || $fake_style eq 'freebsd') &&
460         $symbol eq 'memcmp' && @o == 0) {
461         SKIP: {
462             skip("freebsd memcmp");
463         }
464     } else {
465         ok(@o, "uses $symbol (@o)");
466     }
467 }
468
469 # There are certain symbols we expect NOT to see.
470
471 # gets is horribly unsafe.
472 #
473 # fgets should not be used (Perl has its own API), even without perlio.
474 #
475 # tmpfile is unsafe.
476 #
477 # strcat, strcpy, strncat, strncpy are unsafe.
478 #
479 # sprintf and vsprintf should not be used because
480 # Perl has its own safer and more portable implementations.
481 # (One exception: for certain floating point outputs
482 # the native sprintf is still used in some platforms, see below.)
483 #
484 # XXX: add atoi() to %unexpected - unsafe and undefined failure modes.
485 #
486
487 my %unexpected;
488
489 for my $stdio (qw(gets fgets tmpfile sprintf vsprintf)) {
490     $unexpected{$stdio} = undef; # No Configure symbol for these.
491 }
492 for my $str (qw(strcat strcpy strncat strncpy)) {
493     $unexpected{$str} = undef; # No Configure symbol for these.
494 }
495
496 for my $symbol (sort keys %unexpected) {
497     if (defined $unexpected{$symbol} && !$Config{$unexpected{$symbol}}) {
498       SKIP: {
499         skip("no $symbol");
500       }
501       next;
502     }
503     my @o = exists $symbols{undef}{$symbol} ?
504         sort keys %{ $symbols{undef}{$symbol} } : ();
505     # While sprintf() is bad in the general case,
506     # some platforms implement Gconvert via sprintf, in sv.o.
507     if ($symbol eq 'sprintf' &&
508         $Config{d_Gconvert} =~ /^sprintf/ &&
509         @o == 1 && $o[0] eq 'sv.o') {
510       SKIP: {
511         skip("uses sprintf for Gconvert in sv.o");
512       }
513     } else {
514         is(@o, 0, "uses no $symbol (@o)");
515     }
516 }
517
518 if (defined $nm_err_tmp) {
519     if (open(my $nm_err_fh, $nm_err_tmp)) {
520         my $error;
521         while (<$nm_err_fh>) {
522             # OS X has weird error where nm warns about
523             # "no name list" but then outputs fine.
524             if (/nm: no name list/ && $^O eq 'darwin') {
525                 print "# $^O ignoring $nm output: $_";
526                 next;
527             }
528             warn "$0: Unexpected $nm error: $_";
529             $error++;
530         }
531         die "$0: Unexpected $nm errors\n" if $error;
532     } else {
533         warn "Failed to open '$nm_err_tmp': $!\n";
534     }
535 }
536
537 done_testing();