This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
libperl.t: treat i686 arch the same as x86
[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, x86 only (ppc linux has odd symbol tables)
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{archname} = $Config{archname}\n";
70 print "# \$Config{cc} = $Config{cc}\n";
71 print "# libperl = $libperl_a\n";
72
73 my $nm;
74 my $nm_opt = '';
75 my $nm_style;
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";
93         if ($fake_style eq 'gnu' ||
94             $fake_style eq 'linux' ||
95             $fake_style eq 'freebsd') {
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') {
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') {
111         $nm_style = 'gnu';
112     } elsif ($^O eq 'darwin') {
113         $nm_style = 'darwin';
114     }
115 }
116
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     }
130 }
131
132 if ($^O eq 'linux' && $Config{archname} !~ /^(?:x|i6)86/) {
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
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
154 if ($nm_style eq 'gnu' && !defined $fake_style) {
155     open(my $gnu_verify, "$nm --version|") or
156         skip_all "nm failed: $!";
157     my $gnu_verified;
158     while (<$gnu_verify>) {
159         if (/^GNU nm/) {
160             $gnu_verified = 1;
161             last;
162         }
163     }
164     unless ($gnu_verified) {
165         skip_all "no GNU nm";
166     }
167 }
168
169 if (defined $fake_input) {
170     if ($fake_input eq '-') {
171         open($nm_fh, "<&STDIN") or
172             skip_all "Duping STDIN failed: $!";
173     } else {
174         open($nm_fh, "<", $fake_input) or
175             skip_all "Opening '$fake_input' failed: $!";
176     }
177     undef $nm_err_tmp; # In this case there will be no nm errors.
178 } else {
179     print qq{# command: "$nm $nm_opt $libperl_a 2>$nm_err_tmp |"\n};
180     open($nm_fh, "$nm $nm_opt $libperl_a 2>$nm_err_tmp |") or
181         skip_all "$nm $nm_opt $libperl_a failed: $!";
182 }
183
184 sub is_perlish_symbol {
185     $_[0] =~ /^(?:PL_|Perl|PerlIO)/;
186 }
187
188 # XXX Implement "internal test" for this script (option -t?)
189 # to verify that the parsing does what it's intended to.
190
191 sub nm_parse_gnu {
192     my $symbols = shift;
193     my $line = $_;
194     if (m{^(\w+\.o):$}) {
195         # object file name
196         $symbols->{obj}{$1}++;
197         $symbols->{o} = $1;
198         return;
199     } else {
200         die "$0: undefined current object: $line"
201             unless defined $symbols->{o};
202         # 64-bit systems have 16 hexdigits, 32-bit systems have 8.
203         if (s/^[0-9a-f]{8}(?:[0-9a-f]{8})? //) {
204             if (/^[Rr] (\w+)$/) {
205                 # R: read only (const)
206                 $symbols->{data}{const}{$1}{$symbols->{o}}++;
207             } elsif (/^r .+$/) {
208                 # Skip local const (read only).
209             } elsif (/^([Tti]) (\w+)(\..+)?$/) {
210                 $symbols->{text}{$2}{$symbols->{o}}{$1}++;
211             } elsif (/^C (\w+)$/) {
212                 $symbols->{data}{common}{$1}{$symbols->{o}}++;
213             } elsif (/^[BbSs] (\w+)(\.\d+)?$/) {
214                 # Bb: uninitialized data (bss)
215                 # Ss: uninitialized data "for small objects"
216                 $symbols->{data}{bss}{$1}{$symbols->{o}}++;
217             } elsif (/^D _LIB_VERSION$/) {
218                 # Skip the _LIB_VERSION (not ours, probably libm)
219             } elsif (/^[DdGg] (\w+)$/) {
220                 # Dd: initialized data
221                 # Gg: initialized "for small objects"
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;
228         } elsif (/^ {8}(?: {8})? U _?(\w+)$/) {
229             my ($symbol) = $1;
230             return if is_perlish_symbol($symbol);
231             $symbols->{undef}{$symbol}{$symbols->{o}}++;
232             return;
233         }
234     }
235     print "# Unexpected nm output '$line' ($symbols->{o})\n";
236 }
237
238 sub nm_parse_darwin {
239     my $symbols = shift;
240     my $line = $_;
241     if (m{^(?:.+)?libperl\.a\((\w+\.o)\):$}) {
242         # object file name
243         $symbols->{obj}{$1}++;
244         $symbols->{o} = $1;
245         return;
246     } else {
247         die "$0: undefined current object: $line" unless defined $symbols->{o};
248         # 64-bit systems have 16 hexdigits, 32-bit systems have 8.
249         if (s/^[0-9a-f]{8}(?:[0-9a-f]{8})? //) {
250             # String literals can live in different sections
251             # depending on the compiler and os release, assumedly
252             # also linker flags.
253             if (/^\(__TEXT,__(?:const|cstring|literal\d+)\) (?:non-)?external _?(\w+)(\.\w+)?$/) {
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/;
258                 # Ignore the cstring unnamed strings.
259                 return if $symbol =~ /^L\.str\d+$/;
260                 $symbols->{data}{const}{$symbol}{$symbols->{o}}++;
261             } elsif (/^\(__TEXT,__text\) ((?:non-)?external) _(\w+)$/) {
262                 my ($exp, $sym) = ($1, $2);
263                 $symbols->{text}{$sym}{$symbols->{o}}{$exp =~ /^non/ ? 't' : 'T'}++;
264             } elsif (/^\(__DATA,__\w*?(const|data|bss|common)\w*\) (?:non-)?external _?(\w+)(\.\w+)?$/) {
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?)
273             } elsif (/^\(__TEXT,__eh_frame/) {
274                 # Skip the eh_frame (exception handling) symbols.
275                 return;
276             } elsif (/^\(__\w+,__\w+\) /) {
277                 # Skip the unknown types.
278                 print "# Unknown type: $line ($symbols->{o})\n";
279             }
280             return;
281         } elsif (/^ {8}(?: {8})? \(undefined(?: \[lazy bound\])?\) external _?(.+)/) {
282             # darwin/ppc marks most undefined text symbols
283             # as "[lazy bound]".
284             my ($symbol) = $1 =~ s/\$UNIX2003\z//r;
285             return if is_perlish_symbol($symbol);
286             $symbols->{undef}{$symbol}{$symbols->{o}}++;
287             return;
288         }
289     }
290     print "# Unexpected nm output '$line' ($symbols->{o})\n";
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) {
302     skip_all "no nm parser ($nm_style $nm_style, \$^O $^O)";
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
315 # Something went awfully wrong.  Wrong nm?  Wrong options?
316 unless (keys %symbols) {
317     skip_all "no symbols\n";
318 }
319 unless (exists $symbols{text}) {
320     skip_all "no text symbols\n";
321 }
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
331 my $GS  = $Config{ccflags} =~ /-DPERL_GLOBAL_STRUCT\b/ ? 1 : 0;
332 my $GSP = $Config{ccflags} =~ /-DPERL_GLOBAL_STRUCT_PRIVATE/ ? 1 : 0;
333
334 print "# GS  = $GS\n";
335 print "# GSP = $GSP\n";
336
337 my %data_symbols;
338
339 for my $dtype (sort keys %{$symbols{data}}) {
340     for my $symbol (sort keys %{$symbols{data}{$dtype}}) {
341         $data_symbols{$symbol}++;
342     }
343 }
344
345 # The following tests differ between vanilla vs $GSP or $GS.
346
347 if ($GSP) {
348     print "# -DPERL_GLOBAL_STRUCT_PRIVATE\n";
349     ok(!exists $data_symbols{PL_hash_seed}, "has no PL_hash_seed");
350     ok(!exists $data_symbols{PL_ppaddr}, "has no PL_ppaddr");
351
352     ok(! exists $symbols{data}{bss}, "has no data bss symbols")
353         or do {
354             my $bad = "BSS entries (there are supposed to be none):\n";
355             $bad .= "  bss sym: $_\n" for sort keys %{$symbols{data}{bss}};
356             diag($bad);
357         };
358
359     ok(! exists $symbols{data}{data} ||
360             # clang with ASAN seems to add this symbol to every object file:
361             !grep($_ ne '__unnamed_1', keys %{$symbols{data}{data}}),
362         "has no data data symbols");
363     ok(! exists $symbols{data}{common}, "has no data common symbols");
364
365     # -DPERL_GLOBAL_STRUCT_PRIVATE should NOT have
366     # the extra text symbol for accessing the vars
367     # (as opposed to "just" -DPERL_GLOBAL_STRUCT)
368     ok(! exists $symbols{text}{Perl_GetVars}, "has no Perl_GetVars");
369 } elsif ($GS) {
370     print "# -DPERL_GLOBAL_STRUCT\n";
371     ok(!exists $data_symbols{PL_hash_seed}, "has no PL_hash_seed");
372     ok(!exists $data_symbols{PL_ppaddr}, "has no PL_ppaddr");
373
374     ok(! exists $symbols{data}{bss}, "has no data bss symbols")
375         or do {
376             my $bad = "BSS entries (there are supposed to be none):\n";
377             $bad .= "  bss sym: $_\n" for sort keys %{$symbols{data}{bss}};
378             diag($bad);
379         };
380
381
382     # These PerlIO data symbols are left visible with
383     # -DPERL_GLOBAL_STRUCT (as opposed to -DPERL_GLOBAL_STRUCT_PRIVATE)
384     my @PerlIO =
385         qw(
386            PerlIO_byte
387            PerlIO_crlf
388            PerlIO_pending
389            PerlIO_perlio
390            PerlIO_raw
391            PerlIO_remove
392            PerlIO_stdio
393            PerlIO_unix
394            PerlIO_utf8
395           );
396
397     # PL_magic_vtables is const with -DPERL_GLOBAL_STRUCT_PRIVATE but
398     # otherwise not const -- because of SWIG which wants to modify
399     # the table.  Evil SWIG, eeevil.
400
401     # my_cxt_index is used with PERL_IMPLICIT_CONTEXT, which
402     # -DPERL_GLOBAL_STRUCT has turned on.
403     eq_array([sort keys %{$symbols{data}{data}}],
404              [sort('PL_VarsPtr',
405                    @PerlIO,
406                    'PL_magic_vtables',
407                    'my_cxt_index')],
408              "data data symbols");
409
410     # Only one data common symbol, our "supervariable".
411     eq_array([sort keys %{$symbols{data}{common}}],
412              ['PL_Vars'],
413              "data common symbols");
414
415     ok($symbols{data}{data}{PL_VarsPtr}{'globals.o'}, "has PL_VarsPtr");
416     ok($symbols{data}{common}{PL_Vars}{'globals.o'}, "has PL_Vars");
417
418     # -DPERL_GLOBAL_STRUCT has extra text symbol for accessing the vars.
419     ok($symbols{text}{Perl_GetVars}{'util.o'}, "has Perl_GetVars");
420 } else {
421     print "# neither -DPERL_GLOBAL_STRUCT nor -DPERL_GLOBAL_STRUCT_PRIVATE\n";
422
423     if ( !$symbols{data}{common} ) {
424         # This is likely because Perl was compiled with
425         # -Accflags="-fno-common"
426         $symbols{data}{common} = $symbols{data}{bss};
427     }
428
429     ok($symbols{data}{common}{PL_hash_seed}{'globals.o'}, "has PL_hash_seed");
430     ok($symbols{data}{data}{PL_ppaddr}{'globals.o'}, "has PL_ppaddr");
431
432     # None of the GLOBAL_STRUCT* business here.
433     ok(! exists $symbols{data}{data}{PL_VarsPtr}, "has no PL_VarsPtr");
434     ok(! exists $symbols{data}{common}{PL_Vars}, "has no PL_Vars");
435     ok(! exists $symbols{text}{Perl_GetVars}, "has no Perl_GetVars");
436 }
437
438 # See the comments in the beginning for what "undefined symbols"
439 # really means.  We *should* have many of those, that is a good thing.
440 ok(keys %{$symbols{undef}}, "has undefined symbols");
441
442 # There are certain symbols we expect to see.
443
444 # chmod, socket, getenv, sigaction, exp, time are system/library
445 # calls that should each see at least one use. exp can be expl
446 # if so configured.
447 my %expected = (
448     chmod  => undef, # There is no Configure symbol for chmod.
449     socket => 'd_socket',
450     getenv => undef, # There is no Configure symbol for getenv,
451     sigaction => 'd_sigaction',
452     time   => 'd_time',
453     );
454
455 if ($Config{uselongdouble} && $Config{longdblsize} > $Config{doublesize}) {
456     $expected{expl} = undef; # There is no Configure symbol for expl.
457 } elsif ($Config{usequadmath}) {
458     $expected{expq} = undef; # There is no Configure symbol for expq.
459 } else {
460     $expected{exp} = undef; # There is no Configure symbol for exp.
461 }
462
463 # DynaLoader will use dlopen, unless we are building static,
464 # and it is used in the platforms we are supporting in this test.
465 if ($Config{usedl} ) {
466     $expected{dlopen} = 'd_dlopen';
467 }
468
469 for my $symbol (sort keys %expected) {
470     if (defined $expected{$symbol} && !$Config{$expected{$symbol}}) {
471       SKIP: {
472         skip("no $symbol");
473       }
474       next;
475     }
476     my @o = exists $symbols{undef}{$symbol} ?
477         sort keys %{ $symbols{undef}{$symbol} } : ();
478     ok(@o, "uses $symbol (@o)");
479 }
480
481 # There are certain symbols we expect NOT to see.
482 #
483 # gets is horribly unsafe.
484 #
485 # fgets should not be used (Perl has its own API, sv_gets),
486 # even without perlio.
487 #
488 # tmpfile is unsafe.
489 #
490 # strcat, strcpy, strncat, strncpy are unsafe.
491 #
492 # sprintf and vsprintf should not be used because
493 # Perl has its own safer and more portable implementations.
494 # (One exception: for certain floating point outputs
495 # the native sprintf is still used in some platforms, see below.)
496 #
497 # atoi has unsafe and undefined failure modes, and is affected by locale.
498 # Its cousins include atol and atoll.
499 #
500 # strtol and strtoul are affected by locale.
501 # Cousins include strtoq.
502 #
503 # system should not be used, use pp_system or my_popen.
504 #
505
506 my %unexpected;
507
508 for my $str (qw(system)) {
509     $unexpected{$str} = "d_$str";
510 }
511
512 for my $stdio (qw(gets fgets tmpfile sprintf vsprintf)) {
513     $unexpected{$stdio} = undef; # No Configure symbol for these.
514 }
515 for my $str (qw(strcat strcpy strncat strncpy)) {
516     $unexpected{$str} = undef; # No Configure symbol for these.
517 }
518
519 $unexpected{atoi} = undef; # No Configure symbol for atoi.
520 $unexpected{atol} = undef; # No Configure symbol for atol.
521
522 for my $str (qw(atoll strtol strtoul strtoq)) {
523     $unexpected{$str} = "d_$str";
524 }
525
526 for my $symbol (sort keys %unexpected) {
527     if (defined $unexpected{$symbol} && !$Config{$unexpected{$symbol}}) {
528       SKIP: {
529         skip("no $symbol");
530       }
531       next;
532     }
533     my @o = exists $symbols{undef}{$symbol} ?
534         sort keys %{ $symbols{undef}{$symbol} } : ();
535     # While sprintf() is bad in the general case,
536     # some platforms implement Gconvert via sprintf, in sv.o.
537     if ($symbol eq 'sprintf' &&
538         $Config{d_Gconvert} =~ /^sprintf/ &&
539         @o == 1 && $o[0] eq 'sv.o') {
540       SKIP: {
541         skip("uses sprintf for Gconvert in sv.o");
542       }
543     } else {
544         is(@o, 0, "uses no $symbol (@o)");
545     }
546 }
547
548 # Check that any text symbols named S_ are not exported.
549 my $export_S_prefix = 0;
550 for my $t (sort grep { /^S_/ } keys %{$symbols{text}}) {
551     for my $o (sort keys %{$symbols{text}{$t}}) {
552         if (exists $symbols{text}{$t}{$o}{T}) {
553             fail($t, "$t exported from $o");
554             $export_S_prefix++;
555         }
556     }
557 }
558 is($export_S_prefix, 0, "no S_ exports");
559
560 if (defined $nm_err_tmp) {
561     if (open(my $nm_err_fh, $nm_err_tmp)) {
562         my $error;
563         while (<$nm_err_fh>) {
564             # OS X has weird error where nm warns about
565             # "no name list" but then outputs fine.
566             if (/nm: no name list/ && $^O eq 'darwin') {
567                 print "# $^O ignoring $nm output: $_";
568                 next;
569             }
570             warn "$0: Unexpected $nm error: $_";
571             $error++;
572         }
573         die "$0: Unexpected $nm errors\n" if $error;
574     } else {
575         warn "Failed to open '$nm_err_tmp': $!\n";
576     }
577 }
578
579 done_testing();