This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
test.pl:eq_array() is enough.
[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 symbols
4 # we expected.  Fail softly, expect things only on known platforms.
5 #
6 # Also, if the rarely-used builds options -DPERL_GLOBAL_STRUCT or
7 # -DPERL_GLOBAL_STRUCT_PRIVATE are used, verify that they did what
8 # they were meant to do, hide the global variables (see perlguts for
9 # the details).
10 #
11 # Debugging tip: nm output (this script's input) can be faked by
12 # giving one command line argument for this script: it should be
13 # either the filename to read, or "-" for STDIN.
14
15 BEGIN {
16     chdir 't' if -d 't';
17     @INC = '../lib';
18     require "./test.pl";
19 }
20
21 use strict;
22
23 use Config;
24
25 if ($Config{cc} =~ /g\+\+/) {
26     # XXX Could use c++filt, maybe.
27     skip_all "on g++";
28 }
29
30 my $libperl_a;
31
32 for my $f (qw(../libperl.a libperl.a)) {
33   if (-f $f) {
34     $libperl_a = $f;
35     last;
36   }
37 }
38
39 unless (defined $libperl_a) {
40   skip_all "no libperl.a";
41 }
42
43 print "# \$^O = $^O\n";
44 print "# \$Config{cc} = $Config{cc}\n";
45 print "# libperl = $libperl_a\n";
46
47 my $nm;
48 my $nm_opt = '';
49 my $nm_style;
50
51 if ($^O eq 'linux') {
52     $nm = '/usr/bin/nm';
53     $nm_style = 'gnu';
54 } elsif ($^O eq 'darwin') {
55     $nm = '/usr/bin/nm';
56     $nm_style = 'darwin';
57     # With the -m option we get better information than the BSD-like
58     # default: with the default, a lot of symbols get dumped into 'S'
59     # or 's', for example one cannot tell the difference between const
60     # and non-const symbols.
61     $nm_opt = '-m';
62 }
63
64 unless (defined $nm) {
65   skip_all "no nm";
66 }
67
68 unless (defined $nm_style) {
69   skip_all "no nm style";
70 }
71
72 print "# nm = $nm\n";
73 print "# nm_style = $nm_style\n";
74 print "# nm_opt = $nm_opt\n";
75
76 unless (-x $nm) {
77     skip_all "no executable nm $nm";
78 }
79
80 if ($nm_style eq 'gnu') {
81     open(my $nm_fh, "$nm --version|") or
82         skip_all "nm failed: $!";
83     my $gnu_verified;
84     while (<$nm_fh>) {
85         if (/^GNU nm/) {
86             $gnu_verified = 1;
87             last;
88         }
89     }
90     unless ($gnu_verified) {
91         skip_all "no GNU nm";
92     }
93 }
94
95 my $nm_err_tmp = "libperl$$";
96
97 END {
98     # this is still executed when we skip_all above, avoid a warning
99     unlink $nm_err_tmp if $nm_err_tmp;
100 }
101
102 my $nm_fh;
103
104 if (@ARGV == 1) {
105     my $fake = shift @ARGV;
106     print "# Faking nm output from $fake\n";
107     if ($fake eq '-') {
108         open($nm_fh, "<&STDIN") or
109             skip_all "Duping STDIN failed: $!";
110     } else {
111         open($nm_fh, "<", $fake) or
112             skip_all "Opening '$fake' failed: $!";
113     }
114     undef $nm_err_tmp; # In this case there will be no nm errors.
115 } else {
116     open($nm_fh, "$nm $nm_opt $libperl_a 2>$nm_err_tmp |") or
117         skip_all "$nm $nm_opt $libperl_a failed: $!";
118 }
119  
120 sub nm_parse_gnu {
121     my $symbols = shift;
122     my $line = $_;
123     if (m{^(\w+\.o):$}) {
124         $symbols->{obj}{$1}++;
125         $symbols->{o} = $1;
126         return;
127     } else {
128         die "$0: undefined current object: $line"
129             unless defined $symbols->{o};
130         if (s/^[0-9a-f]{8}(?:[0-9a-f]{8})? //) {
131             if (/^[Rr] (\w+)$/) {
132                 $symbols->{data}{const}{$1}{$symbols->{o}}++;
133             } elsif (/^r .+$/) {
134                 # Skip local const.
135             } elsif (/^[Tti] (\w+)(\..+)?$/) {
136                 $symbols->{text}{$1}{$symbols->{o}}++;
137             } elsif (/^C (\w+)$/) {
138                 $symbols->{data}{common}{$1}{$symbols->{o}}++;
139             } elsif (/^[BbSs] (\w+)(\.\d+)?$/) {
140                 $symbols->{data}{bss}{$1}{$symbols->{o}}++;
141             } elsif (/^0{16} D _LIB_VERSION$/) {
142                 # Skip the _LIB_VERSION (not ours).
143             } elsif (/^[DdGg] (\w+)$/) {
144                 $symbols->{data}{data}{$1}{$symbols->{o}}++;
145             } elsif (/^. \.?(\w+)$/) {
146                 # Skip the unknown types.
147                 print "# Unknown type: $line ($symbols->{o})\n";
148             }
149             return;
150         } elsif (/^ {8}(?: {8})? U (\w+)$/) {
151             # Skip the undefined.
152             return;
153         }
154     }
155     print "# Unexpected nm output '$line' ($symbols->{o})\n";
156 }
157
158 sub nm_parse_darwin {
159     my $symbols = shift;
160     my $line = $_;
161     if (m{^(?:\.\./)?libperl\.a\((\w+\.o)\):$}) {
162         $symbols->{obj}{$1}++;
163         $symbols->{o} = $1;
164         return;
165     } else {
166         die "$0: undefined current object: $line" unless defined $symbols->{o};
167         if (s/^[0-9a-f]{8}(?:[0-9a-f]{8})? //) {
168             if (/^\(__TEXT,__(?:eh_frame|cstring)\) /) {
169                 # Skip the eh_frame and cstring.
170             } elsif (/^\(__TEXT,__(?:const|literal\d+)\) (?:non-)?external _?(\w+)(\.\w+)?$/) {
171                 my ($symbol, $suffix) = ($1, $2);
172                 # Ignore function-local constants like
173                 # _Perl_av_extend_guts.oom_array_extend
174                 return if defined $suffix && /__TEXT,__const/;
175                 $symbols->{data}{const}{$symbol}{$symbols->{o}}++;
176             } elsif (/^\(__TEXT,__text\) (?:non-)?external _(\w+)$/) {
177                 $symbols->{text}{$1}{$symbols->{o}}++;
178             } elsif (/^\(__DATA,__(const|data|bss|common)\) (?:non-)?external _(\w+)(\.\w+)?$/) {
179                 my ($dtype, $symbol, $suffix) = ($1, $2, $3);
180                 # Ignore function-local constants like
181                 # _Perl_pp_gmtime.dayname
182                 return if defined $suffix;
183                 $symbols->{data}{$dtype}{$symbol}{$symbols->{o}}++;
184             } elsif (/^\(__DATA,__const\) non-external _\.memset_pattern\d*$/) {
185                 # Skip this, whatever it is (some inlined leakage from
186                 # darwin libc?)
187             } elsif (/^\(__\w+,__\w+\) /) {
188                 # Skip the unknown types.
189                 print "# Unknown type: $line ($symbols->{o})\n";
190             }
191             return;
192         } elsif (/^ {8}(?: {8})? \(undefined\) /) {
193             # Skip the undefined.
194             return;
195         }
196     }
197     print "# Unexpected nm output '$line' ($symbols->{o})\n";
198 }
199
200 my $nm_parse;
201
202 if ($nm_style eq 'gnu') {
203     $nm_parse = \&nm_parse_gnu;
204 } elsif ($nm_style eq 'darwin') {
205     $nm_parse = \&nm_parse_darwin;
206 }
207
208 unless (defined $nm_parse) {
209     skip_all "no nm parser ($nm_style $nm_style, \$^O $^O)";
210 }
211
212 my %symbols;
213
214 while (<$nm_fh>) {
215     next if /^$/;
216     chomp;
217     $nm_parse->(\%symbols);
218 }
219
220 # use Data::Dumper; print Dumper(\%symbols);
221
222 if (keys %symbols == 0) {
223     skip_all "no symbols\n";
224 }
225
226 # These should always be true for everyone.
227
228 ok($symbols{obj}{'pp.o'}, "has object pp.o");
229 ok($symbols{text}{'Perl_peep'}, "has text Perl_peep");
230 ok($symbols{text}{'Perl_pp_uc'}{'pp.o'}, "has text Perl_pp_uc in pp.o");
231 ok(exists $symbols{data}{const}, "has data const symbols");
232 ok($symbols{data}{const}{PL_no_mem}{'globals.o'}, "has PL_no_mem");
233
234 my $DEBUGGING = $Config{ccflags} =~ /-DDEBUGGING/ ? 1 : 0;
235
236 my $GS  = $Config{ccflags} =~ /-DPERL_GLOBAL_STRUCT\b/ ? 1 : 0;
237 my $GSP = $Config{ccflags} =~ /-DPERL_GLOBAL_STRUCT_PRIVATE/ ? 1 : 0;
238
239 print "# GS  = $GS\n";
240 print "# GSP = $GSP\n";
241
242 my %data_symbols;
243
244 for my $dtype (sort keys %{$symbols{data}}) {
245     for my $symbol (sort keys %{$symbols{data}{$dtype}}) {
246         $data_symbols{$symbol}++;
247     }
248 }
249
250 # The following tests differ between vanilla vs $GSP or $GS.
251 #
252 # Some terminology:
253 # - "text" symbols are code
254 # - "data" symbols are data (duh), with subdivisions:
255 #   - "bss": (Block-Started-by-Symbol: originally from IBM assembler...),
256 #     uninitialized data, which often even doesn't exist in the object
257 #     file as such, only its size does, which is then created on demand
258 #     by the loader
259 #  - "const": initialized read-only data, like string literals
260 #  - "common": uninitialized data unless initialized...
261 #    (the full story is too long for here, see "man nm")
262 #  - "data": initialized read-write data
263 #    (somewhat confusingly below: "data data", but it makes code simpler)
264
265 if ($GSP) {
266     print "# -DPERL_GLOBAL_STRUCT_PRIVATE\n";
267     ok(!exists $data_symbols{PL_hash_seed}, "has no PL_hash_seed");
268     ok(!exists $data_symbols{PL_ppaddr}, "has no PL_ppaddr");
269
270     ok(! exists $symbols{data}{bss}, "has no data bss symbols");
271     ok(! exists $symbols{data}{data} ||
272             # clang with ASAN seems to add this symbol to every object file:
273             !grep($_ ne '__unnamed_1', keys %{$symbols{data}{data}}),
274         "has no data data symbols");
275     ok(! exists $symbols{data}{common}, "has no data common symbols");
276
277     # -DPERL_GLOBAL_STRUCT_PRIVATE should NOT have
278     # the extra text symbol for accessing the vars
279     # (as opposed to "just" -DPERL_GLOBAL_STRUCT)
280     ok(! exists $symbols{text}{Perl_GetVars}, "has no Perl_GetVars");
281 } elsif ($GS) {
282     print "# -DPERL_GLOBAL_STRUCT\n";
283     ok(!exists $data_symbols{PL_hash_seed}, "has no PL_hash_seed");
284     ok(!exists $data_symbols{PL_ppaddr}, "has no PL_ppaddr");
285
286     ok(! exists $symbols{data}{bss}, "has no data bss symbols");
287
288     # These PerlIO data symbols are left visible with
289     # -DPERL_GLOBAL_STRUCT (as opposed to -DPERL_GLOBAL_STRUCT_PRIVATE)
290     my @PerlIO =
291         qw(
292            PerlIO_byte
293            PerlIO_crlf
294            PerlIO_pending
295            PerlIO_perlio
296            PerlIO_raw
297            PerlIO_remove
298            PerlIO_stdio
299            PerlIO_unix
300            PerlIO_utf8
301           );
302
303     # PL_magic_vtables is const with -DPERL_GLOBAL_STRUCT_PRIVATE but
304     # otherwise not const -- because of SWIG which wants to modify
305     # the table.  Evil SWIG, eeevil.
306
307     # my_cxt_index is used with PERL_IMPLICIT_CONTEXT, which
308     # -DPERL_GLOBAL_STRUCT has turned on.
309     eq_array([sort keys %{$symbols{data}{data}}],
310              [sort('PL_VarsPtr',
311                    @PerlIO,
312                    'PL_magic_vtables',
313                    'my_cxt_index')],
314              "data data symbols");
315
316     # Only one data common symbol, our "supervariable".
317     eq_array([sort keys %{$symbols{data}{common}}],
318              ['PL_Vars'],
319              "data common symbols");
320
321     ok($symbols{data}{data}{PL_VarsPtr}{'globals.o'}, "has PL_VarsPtr");
322     ok($symbols{data}{common}{PL_Vars}{'globals.o'}, "has PL_Vars");
323
324     # -DPERL_GLOBAL_STRUCT has extra text symbol for accessing the vars.
325     ok($symbols{text}{Perl_GetVars}{'util.o'}, "has Perl_GetVars");
326 } else {
327     print "# neither -DPERL_GLOBAL_STRUCT nor -DPERL_GLOBAL_STRUCT_PRIVATE\n";
328
329     if ( !$symbols{data}{common} ) {
330         # This is likely because Perl was compiled with 
331         # -Accflags="-fno-common"
332         $symbols{data}{common} = $symbols{data}{bss};
333     }
334     
335     ok($symbols{data}{common}{PL_hash_seed}{'globals.o'}, "has PL_hash_seed");
336     ok($symbols{data}{data}{PL_ppaddr}{'globals.o'}, "has PL_ppaddr");
337
338     # None of the GLOBAL_STRUCT* business here.
339     ok(! exists $symbols{data}{data}{PL_VarsPtr}, "has no PL_VarsPtr");
340     ok(! exists $symbols{data}{common}{PL_Vars}, "has no PL_Vars");
341     ok(! exists $symbols{text}{Perl_GetVars}, "has no Perl_GetVars");
342 }
343
344 if (defined $nm_err_tmp) {
345     if (open(my $nm_err_fh, $nm_err_tmp)) {
346         my $error;
347         while (<$nm_err_fh>) {
348             # OS X has weird error where nm warns about
349             # "no name list" but then outputs fine.
350             if (/nm: no name list/ && $^O eq 'darwin') {
351                 print "# $^O ignoring $nm output: $_";
352                 next;
353             }
354             warn "$0: Unexpected $nm error: $_";
355             $error++;
356         }
357         die "$0: Unexpected $nm errors\n" if $error;
358     } else {
359         warn "Failed to open '$nm_err_tmp': $!\n";
360     }
361 }
362
363 done_testing();