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