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