| 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,__(?:const|cstring|literal\d+)\) (?:non-)?external _?(\w+)(\.\w+)?$/) { |
| 169 | my ($symbol, $suffix) = ($1, $2); |
| 170 | # Ignore function-local constants like |
| 171 | # _Perl_av_extend_guts.oom_array_extend |
| 172 | return if defined $suffix && /__TEXT,__const/; |
| 173 | # Ignore the cstring unnamed strings. |
| 174 | return if $symbol =~ /^L\.str\d+$/; |
| 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 (/^\(__TEXT,__eh_frame/) { |
| 188 | # Skip the eh_frame symbols. |
| 189 | return; |
| 190 | } elsif (/^\(__\w+,__\w+\) /) { |
| 191 | # Skip the unknown types. |
| 192 | print "# Unknown type: $line ($symbols->{o})\n"; |
| 193 | } |
| 194 | return; |
| 195 | } elsif (/^ {8}(?: {8})? \(undefined\) /) { |
| 196 | # Skip the undefined. |
| 197 | return; |
| 198 | } |
| 199 | } |
| 200 | print "# Unexpected nm output '$line' ($symbols->{o})\n"; |
| 201 | } |
| 202 | |
| 203 | my $nm_parse; |
| 204 | |
| 205 | if ($nm_style eq 'gnu') { |
| 206 | $nm_parse = \&nm_parse_gnu; |
| 207 | } elsif ($nm_style eq 'darwin') { |
| 208 | $nm_parse = \&nm_parse_darwin; |
| 209 | } |
| 210 | |
| 211 | unless (defined $nm_parse) { |
| 212 | skip_all "no nm parser ($nm_style $nm_style, \$^O $^O)"; |
| 213 | } |
| 214 | |
| 215 | my %symbols; |
| 216 | |
| 217 | while (<$nm_fh>) { |
| 218 | next if /^$/; |
| 219 | chomp; |
| 220 | $nm_parse->(\%symbols); |
| 221 | } |
| 222 | |
| 223 | # use Data::Dumper; print Dumper(\%symbols); |
| 224 | |
| 225 | if (keys %symbols == 0) { |
| 226 | skip_all "no symbols\n"; |
| 227 | } |
| 228 | |
| 229 | # These should always be true for everyone. |
| 230 | |
| 231 | ok($symbols{obj}{'pp.o'}, "has object pp.o"); |
| 232 | ok($symbols{text}{'Perl_peep'}, "has text Perl_peep"); |
| 233 | ok($symbols{text}{'Perl_pp_uc'}{'pp.o'}, "has text Perl_pp_uc in pp.o"); |
| 234 | ok(exists $symbols{data}{const}, "has data const symbols"); |
| 235 | ok($symbols{data}{const}{PL_no_mem}{'globals.o'}, "has PL_no_mem"); |
| 236 | |
| 237 | my $DEBUGGING = $Config{ccflags} =~ /-DDEBUGGING/ ? 1 : 0; |
| 238 | |
| 239 | my $GS = $Config{ccflags} =~ /-DPERL_GLOBAL_STRUCT\b/ ? 1 : 0; |
| 240 | my $GSP = $Config{ccflags} =~ /-DPERL_GLOBAL_STRUCT_PRIVATE/ ? 1 : 0; |
| 241 | |
| 242 | print "# GS = $GS\n"; |
| 243 | print "# GSP = $GSP\n"; |
| 244 | |
| 245 | my %data_symbols; |
| 246 | |
| 247 | for my $dtype (sort keys %{$symbols{data}}) { |
| 248 | for my $symbol (sort keys %{$symbols{data}{$dtype}}) { |
| 249 | $data_symbols{$symbol}++; |
| 250 | } |
| 251 | } |
| 252 | |
| 253 | # The following tests differ between vanilla vs $GSP or $GS. |
| 254 | # |
| 255 | # Some terminology: |
| 256 | # - "text" symbols are code |
| 257 | # - "data" symbols are data (duh), with subdivisions: |
| 258 | # - "bss": (Block-Started-by-Symbol: originally from IBM assembler...), |
| 259 | # uninitialized data, which often even doesn't exist in the object |
| 260 | # file as such, only its size does, which is then created on demand |
| 261 | # by the loader |
| 262 | # - "const": initialized read-only data, like string literals |
| 263 | # - "common": uninitialized data unless initialized... |
| 264 | # (the full story is too long for here, see "man nm") |
| 265 | # - "data": initialized read-write data |
| 266 | # (somewhat confusingly below: "data data", but it makes code simpler) |
| 267 | |
| 268 | if ($GSP) { |
| 269 | print "# -DPERL_GLOBAL_STRUCT_PRIVATE\n"; |
| 270 | ok(!exists $data_symbols{PL_hash_seed}, "has no PL_hash_seed"); |
| 271 | ok(!exists $data_symbols{PL_ppaddr}, "has no PL_ppaddr"); |
| 272 | |
| 273 | ok(! exists $symbols{data}{bss}, "has no data bss symbols"); |
| 274 | ok(! exists $symbols{data}{data} || |
| 275 | # clang with ASAN seems to add this symbol to every object file: |
| 276 | !grep($_ ne '__unnamed_1', keys %{$symbols{data}{data}}), |
| 277 | "has no data data symbols"); |
| 278 | ok(! exists $symbols{data}{common}, "has no data common symbols"); |
| 279 | |
| 280 | # -DPERL_GLOBAL_STRUCT_PRIVATE should NOT have |
| 281 | # the extra text symbol for accessing the vars |
| 282 | # (as opposed to "just" -DPERL_GLOBAL_STRUCT) |
| 283 | ok(! exists $symbols{text}{Perl_GetVars}, "has no Perl_GetVars"); |
| 284 | } elsif ($GS) { |
| 285 | print "# -DPERL_GLOBAL_STRUCT\n"; |
| 286 | ok(!exists $data_symbols{PL_hash_seed}, "has no PL_hash_seed"); |
| 287 | ok(!exists $data_symbols{PL_ppaddr}, "has no PL_ppaddr"); |
| 288 | |
| 289 | ok(! exists $symbols{data}{bss}, "has no data bss symbols"); |
| 290 | |
| 291 | # These PerlIO data symbols are left visible with |
| 292 | # -DPERL_GLOBAL_STRUCT (as opposed to -DPERL_GLOBAL_STRUCT_PRIVATE) |
| 293 | my @PerlIO = |
| 294 | qw( |
| 295 | PerlIO_byte |
| 296 | PerlIO_crlf |
| 297 | PerlIO_pending |
| 298 | PerlIO_perlio |
| 299 | PerlIO_raw |
| 300 | PerlIO_remove |
| 301 | PerlIO_stdio |
| 302 | PerlIO_unix |
| 303 | PerlIO_utf8 |
| 304 | ); |
| 305 | |
| 306 | # PL_magic_vtables is const with -DPERL_GLOBAL_STRUCT_PRIVATE but |
| 307 | # otherwise not const -- because of SWIG which wants to modify |
| 308 | # the table. Evil SWIG, eeevil. |
| 309 | |
| 310 | # my_cxt_index is used with PERL_IMPLICIT_CONTEXT, which |
| 311 | # -DPERL_GLOBAL_STRUCT has turned on. |
| 312 | eq_array([sort keys %{$symbols{data}{data}}], |
| 313 | [sort('PL_VarsPtr', |
| 314 | @PerlIO, |
| 315 | 'PL_magic_vtables', |
| 316 | 'my_cxt_index')], |
| 317 | "data data symbols"); |
| 318 | |
| 319 | # Only one data common symbol, our "supervariable". |
| 320 | eq_array([sort keys %{$symbols{data}{common}}], |
| 321 | ['PL_Vars'], |
| 322 | "data common symbols"); |
| 323 | |
| 324 | ok($symbols{data}{data}{PL_VarsPtr}{'globals.o'}, "has PL_VarsPtr"); |
| 325 | ok($symbols{data}{common}{PL_Vars}{'globals.o'}, "has PL_Vars"); |
| 326 | |
| 327 | # -DPERL_GLOBAL_STRUCT has extra text symbol for accessing the vars. |
| 328 | ok($symbols{text}{Perl_GetVars}{'util.o'}, "has Perl_GetVars"); |
| 329 | } else { |
| 330 | print "# neither -DPERL_GLOBAL_STRUCT nor -DPERL_GLOBAL_STRUCT_PRIVATE\n"; |
| 331 | |
| 332 | if ( !$symbols{data}{common} ) { |
| 333 | # This is likely because Perl was compiled with |
| 334 | # -Accflags="-fno-common" |
| 335 | $symbols{data}{common} = $symbols{data}{bss}; |
| 336 | } |
| 337 | |
| 338 | ok($symbols{data}{common}{PL_hash_seed}{'globals.o'}, "has PL_hash_seed"); |
| 339 | ok($symbols{data}{data}{PL_ppaddr}{'globals.o'}, "has PL_ppaddr"); |
| 340 | |
| 341 | # None of the GLOBAL_STRUCT* business here. |
| 342 | ok(! exists $symbols{data}{data}{PL_VarsPtr}, "has no PL_VarsPtr"); |
| 343 | ok(! exists $symbols{data}{common}{PL_Vars}, "has no PL_Vars"); |
| 344 | ok(! exists $symbols{text}{Perl_GetVars}, "has no Perl_GetVars"); |
| 345 | } |
| 346 | |
| 347 | if (defined $nm_err_tmp) { |
| 348 | if (open(my $nm_err_fh, $nm_err_tmp)) { |
| 349 | my $error; |
| 350 | while (<$nm_err_fh>) { |
| 351 | # OS X has weird error where nm warns about |
| 352 | # "no name list" but then outputs fine. |
| 353 | if (/nm: no name list/ && $^O eq 'darwin') { |
| 354 | print "# $^O ignoring $nm output: $_"; |
| 355 | next; |
| 356 | } |
| 357 | warn "$0: Unexpected $nm error: $_"; |
| 358 | $error++; |
| 359 | } |
| 360 | die "$0: Unexpected $nm errors\n" if $error; |
| 361 | } else { |
| 362 | warn "Failed to open '$nm_err_tmp': $!\n"; |
| 363 | } |
| 364 | } |
| 365 | |
| 366 | done_testing(); |