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