This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Capture the stderr of "nm libperl.a".
[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         plan skil_all => "no GNU nm";
86     }
87 }
88
89 my $nm_err_tmp = "libperl$$";
90
91 END {
92     unlink $nm_err_tmp;
93 }
94
95 open(my $nm_fh, "$nm $nm_opt $libperl_a 2>$nm_err_tmp |") or
96     skip_all "$nm $nm_opt $libperl_a failed: $!";
97
98 sub nm_parse_gnu {
99     my $symbols = shift;
100     if (m{^(\w+\.o):$}) {
101         $symbols->{obj}{$1}++;
102         $symbols->{o} = $1;
103     } else {
104         die "$0: undefined current object: $_" unless defined $symbols->{o};
105         if (/^[0-9a-f]{16} [Rr] (\w+)$/) {
106             $symbols->{data}{const}{$1}{$symbols->{o}}++;
107         } elsif (/^[0-9a-f]{16} r .+$/) {
108             # Skip local const.
109         } elsif (/^[0-9a-f]{16} [Tti] (\w+)(\..+)?$/) {
110             $symbols->{text}{$1}{$symbols->{o}}++;
111         } elsif (/^[0-9a-f]{16} C (\w+)$/) {
112             $symbols->{data}{common}{$1}{$symbols->{o}}++;
113         } elsif (/^[0-9a-f]{16} [BbSs] (\w+)(\.\d+)?$/) {
114             $symbols->{data}{bss}{$1}{$symbols->{o}}++;
115         } elsif (/^0{16} D _LIB_VERSION$/) {
116             # Skip the _LIB_VERSION (not ours).
117         } elsif (/^[0-9a-f]{16} [DdGg] (\w+)$/) {
118             $symbols->{data}{data}{$1}{$symbols->{o}}++;
119         } elsif (/^ {16} U (\w+)$/) {
120             # Skip the undefined.
121         } elsif (/^[0-9a-f]{16} . \.?(\w+)$/) {
122             # Skip the unknown types.
123             print "# Unknown type: $_ ($symbols->{o})\n";
124         } else {
125             print "# Unexpected nm output '$_' ($symbols->{o})\n";
126         }
127     }
128 }
129
130 sub nm_parse_darwin {
131     my $symbols = shift;
132     if (m{^(?:\.\./)?libperl\.a\((\w+\.o)\):$}) {
133         $symbols->{obj}{$1}++;
134         $symbols->{o} = $1;
135     } else {
136         die "$0: undefined current object: $_" unless defined $symbols->{o};
137         if (/^[0-9a-f]{16} \(__TEXT,__(?:eh_frame|cstring)\) /) {
138             # Skip the eh_frame and cstring.
139         } elsif (/^[0-9a-f]{16} \(__TEXT,__(?:const|literal\d+)\) (?:non-)?external _?(\w+)(\.\w+)?$/) {
140             my ($symbol, $suffix) = ($1, $2);
141             # Ignore function-local constants like
142             # _Perl_av_extend_guts.oom_array_extend
143             return if defined $suffix && /__TEXT,__const/;
144             $symbols->{data}{const}{$symbol}{$symbols->{o}}++;
145         } elsif (/^[0-9a-f]{16} \(__TEXT,__text\) (?:non-)?external _(\w+)$/) {
146             $symbols->{text}{$1}{$symbols->{o}}++;
147         } elsif (/^[0-9a-f]{16} \(__DATA,__(const|data|bss|common)\) (?:non-)?external _(\w+)(\.\w+)?$/) {
148             my ($dtype, $symbol, $suffix) = ($1, $2, $3);
149             # Ignore function-local constants like
150             # _Perl_pp_gmtime.dayname
151             return if defined $suffix;
152             $symbols->{data}{$dtype}{$symbol}{$symbols->{o}}++;
153         } elsif (/^[0-9a-f]{16} \(__DATA,__const\) non-external _\.memset_pattern\d*$/) {
154             # Skip this, whatever it is (some inlined leakage from darwin libc?)
155         } elsif (/^ {16} \(undefined\) /) {
156             # Skip the undefined.
157         } elsif (/^[0-9a-f]{16} \(__\w+,__\w+\) /) {
158             # Skip the unknown types.
159             print "# Unknown type: $_ ($symbols->{o})\n";
160         } else {
161             print "# Unexpected nm output '$_' ($symbols->{o})\n";
162         }
163     }
164 }
165
166 my $nm_parse;
167
168 if ($nm_style eq 'gnu') {
169     $nm_parse = \&nm_parse_gnu;
170 } elsif ($nm_style eq 'darwin') {
171     $nm_parse = \&nm_parse_darwin;
172 }
173
174 unless (defined $nm_parse) {
175     skip_all "no nm parser";
176 }
177
178 my %symbols;
179
180 while (<$nm_fh>) {
181     next if /^$/;
182     chomp;
183     $nm_parse->(\%symbols);
184 }
185
186 # use Data::Dumper; print Dumper(\%symbols);
187
188 if (keys %symbols == 0) {
189     skip_all "no symbols\n";
190 }
191
192 # These should always be true for everyone.
193
194 ok($symbols{obj}{'pp.o'}, "has object pp.o");
195 ok($symbols{text}{'Perl_peep'}, "has text Perl_peep");
196 ok($symbols{text}{'Perl_pp_uc'}{'pp.o'}, "has text Perl_pp_uc in pp.o");
197 ok(exists $symbols{data}{const}, "has data const symbols");
198 ok($symbols{data}{const}{PL_no_mem}{'globals.o'}, "has PL_no_mem");
199
200 my $DEBUGGING = $Config{ccflags} =~ /-DDEBUGGING/ ? 1 : 0;
201
202 my $GS  = $Config{ccflags} =~ /-DPERL_GLOBAL_STRUCT\b/ ? 1 : 0;
203 my $GSP = $Config{ccflags} =~ /-DPERL_GLOBAL_STRUCT_PRIVATE/ ? 1 : 0;
204
205 print "# GS  = $GS\n";
206 print "# GSP = $GSP\n";
207
208 my %data_symbols;
209
210 for my $dtype (sort keys %{$symbols{data}}) {
211     for my $symbol (sort keys %{$symbols{data}{$dtype}}) {
212         $data_symbols{$symbol}++;
213     }
214 }
215
216 # Since we are deprived of Test::More.
217 sub is_deeply {
218     my ($a, $b) = @_;
219     if (ref $a eq 'ARRAY' && ref $b eq 'ARRAY') {
220         if (@$a == @$b) {
221             for my $i (0..$#$a) {
222                 unless ($a->[$i] eq $b->[$i]) {
223                     printf("# LHS elem #%d '%s' ne RHS elem #%d '%s'\n",
224                            $a->[$i], $b->[$i]);
225                     return 0;
226                 }
227             }
228             return 1;
229         } else {
230             printf("# LHS length %d, RHS length %d\n",
231                    @$a, @$b);
232             return 0;
233         }
234     } else {
235         die "$0: Unexpcted: is_deeply $a $b\n";
236     }
237 }
238
239 # The following tests differ between vanilla vs $GSP or $GS.
240 #
241 # Some terminology:
242 # - "text" symbols are code
243 # - "data" symbols are data (duh), with subdivisions:
244 #   - "bss": (Block-Started-by-Symbol: originally from IBM assembler...),
245 #     uninitialized data, which often even doesn't exist in the object
246 #     file as such, only its size does, which is then created on demand
247 #     by the loader
248 #  - "const": initialized read-only data, like string literals
249 #  - "common": uninitialized data unless initialized...
250 #    (the full story is too long for here, see "man nm")
251 #  - "data": initialized read-write data
252 #    (somewhat confusingly below: "data data", but it makes code simpler)
253
254 if ($GSP) {
255     print "# -DPERL_GLOBAL_STRUCT_PRIVATE\n";
256     ok(!exists $data_symbols{PL_hash_seed}, "has no PL_hash_seed");
257     ok(!exists $data_symbols{PL_ppaddr}, "has no PL_ppaddr");
258
259     ok(! exists $symbols{data}{bss}, "has no data bss symbols");
260     ok(! exists $symbols{data}{data}, "has no data data symbols");
261     ok(! exists $symbols{data}{common}, "has no data common symbols");
262
263     # -DPERL_GLOBAL_STRUCT_PRIVATE should NOT have
264     # the extra text symbol for accessing the vars
265     # (as opposed to "just" -DPERL_GLOBAL_STRUCT)
266     ok(! exists $symbols{text}{Perl_GetVars}, "has no Perl_GetVars");
267 } elsif ($GS) {
268     print "# -DPERL_GLOBAL_STRUCT\n";
269     ok(!exists $data_symbols{PL_hash_seed}, "has no PL_hash_seed");
270     ok(!exists $data_symbols{PL_ppaddr}, "has no PL_ppaddr");
271
272     ok(! exists $symbols{data}{bss}, "has no data bss symbols");
273
274     # These PerlIO data symbols are left visible with
275     # -DPERL_GLOBAL_STRUCT (as opposed to -DPERL_GLOBAL_STRUCT_PRIVATE)
276     my @PerlIO =
277         qw(
278            PerlIO_byte
279            PerlIO_crlf
280            PerlIO_pending
281            PerlIO_perlio
282            PerlIO_raw
283            PerlIO_remove
284            PerlIO_stdio
285            PerlIO_unix
286            PerlIO_utf8
287           );
288
289     # PL_magic_vtables is const with -DPERL_GLOBAL_STRUCT_PRIVATE but
290     # otherwise not const -- because of SWIG which wants to modify
291     # the table.  Evil SWIG, eeevil.
292
293     # my_cxt_index is used with PERL_IMPLICIT_CONTEXT, which
294     # -DPERL_GLOBAL_STRUCT has turned on.
295     is_deeply([sort keys %{$symbols{data}{data}}],
296               [sort('PL_VarsPtr',
297                     @PerlIO,
298                     'PL_magic_vtables',
299                     'my_cxt_index')],
300               "data data symbols");
301
302     # Only one data common symbol, our "supervariable".
303     is_deeply([sort keys %{$symbols{data}{common}}],
304               ['PL_Vars'],
305               "data common symbols");
306
307     ok($symbols{data}{data}{PL_VarsPtr}{'globals.o'}, "has PL_VarsPtr");
308     ok($symbols{data}{common}{PL_Vars}{'globals.o'}, "has PL_Vars");
309
310     # -DPERL_GLOBAL_STRUCT has extra text symbol for accessing the vars.
311     ok($symbols{text}{Perl_GetVars}{'util.o'}, "has Perl_GetVars");
312 } else {
313     print "# neither -DPERL_GLOBAL_STRUCT nor -DPERL_GLOBAL_STRUCT_PRIVATE\n";
314
315     ok($symbols{data}{common}{PL_hash_seed}{'globals.o'}, "has PL_hash_seed");
316     ok($symbols{data}{data}{PL_ppaddr}{'globals.o'}, "has PL_ppaddr");
317
318     # None of the GLOBAL_STRUCT* business here.
319     ok(! exists $symbols{data}{data}{PL_VarsPtr}, "has no PL_VarsPtr");
320     ok(! exists $symbols{data}{common}{PL_Vars}, "has no PL_Vars");
321     ok(! exists $symbols{text}{Perl_GetVars}, "has no Perl_GetVars");
322 }
323
324 if (open(my $nm_err_fh, $nm_err_tmp)) {
325     my $error;
326     while (<$nm_err_fh>) {
327         if (/warning: .+nm: no name list/ && $^O eq 'darwin') {
328             print "# $^O ignoring $nm output: $_";
329             next;
330         }
331         warn "$0: Unexpected $nm error: $_";
332         $error++;
333     }
334     die "$0: Unexpected $nm errors\n" if $error;
335 } else {
336     warn "Failed to open '$nm_err_tmp': $!\n";
337 }
338
339 done_testing();