t/porting/libperl.t

   1 #!/usr/bin/perl -w
   2
   3 # Try opening libperl.a with nm, and verifying it has the kind of
   4 # symbols we expect, and no symbols we should avoid.
   5 #
   6 # Fail softly, expect things only on known platforms.
   7 #
   8 # Also, if the rarely-used builds options -DPERL_GLOBAL_STRUCT or
   9 # -DPERL_GLOBAL_STRUCT_PRIVATE are used, verify that they did what
  10 # they were meant to do, hide the global variables (see perlguts for
  11 # the details).
  12 #
  13 # Debugging tip: nm output (this script's input) can be faked by
  14 # giving one command line argument for this script: it should be
  15 # either the filename to read, or "-" for STDIN.  You can also append
  16 # "@style" (where style is a supported nm style, like "gnu" or "darwin")
  17 # to this filename for "cross-parsing".
  18 #
  19 # Some terminology:
  20 # - "text" symbols are code
  21 # - "data" symbols are data (duh), with subdivisions:
  22 #   - "bss": (Block-Started-by-Symbol: originally from IBM assembler...),
  23 #     uninitialized data, which often even doesn't exist in the object
  24 #     file as such, only its size does, which is then created on demand
  25 #     by the loader
  26 #  - "const": initialized read-only data, like string literals
  27 #  - "common": uninitialized data unless initialized...
  28 #    (the full story is too long for here, see "man nm")
  29 #  - "data": initialized read-write data
  30 #    (somewhat confusingly below: "data data", but it makes code simpler)
  31 #  - "undefined": external symbol referred to by an object,
  32 #    most likely a text symbol.  Can be either a symbol defined by
  33 #    a Perl object file but referred to by other Perl object files,
  34 #    or a completely external symbol from libc, or other system libraries.
  35
  36 BEGIN {
  37     chdir 't' if -d 't';
  38     @INC = '../lib';
  39     require "./test.pl";
  40 }
  41
  42 use strict;
  43
  44 use Config;
  45
  46 if ($Config{cc} =~ /g\+\+/) {
  47     # XXX Could use c++filt, maybe.
  48     skip_all "on g++";
  49 }
  50
  51 my $libperl_a;
  52
  53 for my $f (qw(../libperl.a libperl.a)) {
  54   if (-f $f) {
  55     $libperl_a = $f;
  56     last;
  57   }
  58 }
  59
  60 unless (defined $libperl_a) {
  61   skip_all "no libperl.a";
  62 }
  63
  64 print "# \$^O = $^O\n";
  65 print "# \$Config{cc} = $Config{cc}\n";
  66 print "# libperl = $libperl_a\n";
  67
  68 my $nm;
  69 my $nm_opt = '';
  70 my $nm_style;
  71 my $nm_fh;
  72 my $nm_err_tmp = "libperl$$";
  73
  74 END {
  75     # this is still executed when we skip_all above, avoid a warning
  76     unlink $nm_err_tmp if $nm_err_tmp;
  77 }
  78
  79 my $fake_input;
  80 my $fake_style;
  81
  82 if (@ARGV == 1) {
  83     $fake_input = shift @ARGV;
  84     print "# Faking nm output from $fake_input\n";
  85     if ($fake_input =~ s/\@(.+)$//) {
  86         $fake_style = $1;
  87         print "# Faking nm style from $fake_style\n";
  88         if ($fake_style eq 'gnu' || $fake_style eq 'linux') {
  89             $nm_style = 'gnu'
  90         } elsif ($fake_style eq 'darwin' || $fake_style eq 'osx') {
  91             $nm_style = 'darwin'
  92         } else {
  93             die "$0: Unknown explicit nm style '$fake_style'\n";
  94         }
  95     }
  96 }
  97
  98 unless (defined $nm_style) {
  99     if ($^O eq 'linux') {
 100         $nm_style = 'gnu';
 101     } elsif ($^O eq 'darwin') {
 102         $nm_style = 'darwin';
 103     }
 104 }
 105
 106 if (defined $nm_style) {
 107     if ($nm_style eq 'gnu') {
 108         $nm = '/usr/bin/nm';
 109     } elsif ($nm_style eq 'darwin') {
 110         $nm = '/usr/bin/nm';
 111         # With the -m option we get better information than the BSD-like
 112         # default: with the default, a lot of symbols get dumped into 'S'
 113         # or 's', for example one cannot tell the difference between const
 114         # and non-const data symbols.
 115         $nm_opt = '-m';
 116     } else {
 117         die "$0: Unexpected nm style '$nm_style'\n";
 118     }
 119 }
 120
 121 unless (defined $nm) {
 122   skip_all "no nm";
 123 }
 124
 125 unless (defined $nm_style) {
 126   skip_all "no nm style";
 127 }
 128
 129 print "# nm = $nm\n";
 130 print "# nm_style = $nm_style\n";
 131 print "# nm_opt = $nm_opt\n";
 132
 133 unless (-x $nm) {
 134     skip_all "no executable nm $nm";
 135 }
 136
 137 if ($nm_style eq 'gnu' && !defined $fake_style) {
 138     open(my $gnu_verify, "$nm --version|") or
 139         skip_all "nm failed: $!";
 140     my $gnu_verified;
 141     while (<$gnu_verify>) {
 142         if (/^GNU nm/) {
 143             $gnu_verified = 1;
 144             last;
 145         }
 146     }
 147     unless ($gnu_verified) {
 148         skip_all "no GNU nm";
 149     }
 150 }
 151
 152 if (defined $fake_input) {
 153     if ($fake_input eq '-') {
 154         open($nm_fh, "<&STDIN") or
 155             skip_all "Duping STDIN failed: $!";
 156     } else {
 157         open($nm_fh, "<", $fake_input) or
 158             skip_all "Opening '$fake_input' failed: $!";
 159     }
 160     undef $nm_err_tmp; # In this case there will be no nm errors.
 161 } else {
 162     open($nm_fh, "$nm $nm_opt $libperl_a 2>$nm_err_tmp |") or
 163         skip_all "$nm $nm_opt $libperl_a failed: $!";
 164 }
 165
 166 sub is_perlish_symbol {
 167     $_[0] =~ /^(?:PL_|Perl|PerlIO)/;
 168 }
 169
 170 # XXX Implement "internal test" for this script (option -t?)
 171 # to verify that the parsing does what it's intended to.
 172
 173 sub nm_parse_gnu {
 174     my $symbols = shift;
 175     my $line = $_;
 176     if (m{^(\w+\.o):$}) {
 177         # object file name
 178         $symbols->{obj}{$1}++;
 179         $symbols->{o} = $1;
 180         return;
 181     } else {
 182         die "$0: undefined current object: $line"
 183             unless defined $symbols->{o};
 184         # 64-bit systems have 16 hexdigits, 32-bit systems have 8.
 185         if (s/^[0-9a-f]{8}(?:[0-9a-f]{8})? //) {
 186             if (/^[Rr] (\w+)$/) {
 187                 # R: read only (const)
 188                 $symbols->{data}{const}{$1}{$symbols->{o}}++;
 189             } elsif (/^r .+$/) {
 190                 # Skip local const (read only).
 191             } elsif (/^[Tti] (\w+)(\..+)?$/) {
 192                 $symbols->{text}{$1}{$symbols->{o}}++;
 193             } elsif (/^C (\w+)$/) {
 194                 $symbols->{data}{common}{$1}{$symbols->{o}}++;
 195             } elsif (/^[BbSs] (\w+)(\.\d+)?$/) {
 196                 # Bb: uninitialized data (bss)
 197                 # Ss: uninitialized data "for small objects"
 198                 $symbols->{data}{bss}{$1}{$symbols->{o}}++;
 199             } elsif (/^0{16} D _LIB_VERSION$/) {
 200                 # Skip the _LIB_VERSION (not ours, probably libm)
 201             } elsif (/^[DdGg] (\w+)$/) {
 202                 # Dd: initialized data
 203                 # Gg: initialized "for small objects"
 204                 $symbols->{data}{data}{$1}{$symbols->{o}}++;
 205             } elsif (/^. \.?(\w+)$/) {
 206                 # Skip the unknown types.
 207                 print "# Unknown type: $line ($symbols->{o})\n";
 208             }
 209             return;
 210         } elsif (/^ {8}(?: {8})? U _?(\w+)$/) {
 211             my ($symbol) = $1;
 212             return if is_perlish_symbol($symbol);
 213             $symbols->{undef}{$symbol}{$symbols->{o}}++;
 214             return;
 215         }
 216     }
 217     print "# Unexpected nm output '$line' ($symbols->{o})\n";
 218 }
 219
 220 sub nm_parse_darwin {
 221     my $symbols = shift;
 222     my $line = $_;
 223     if (m{^(?:.+)?libperl\.a\((\w+\.o)\):$}) {
 224         # object file name
 225         $symbols->{obj}{$1}++;
 226         $symbols->{o} = $1;
 227         return;
 228     } else {
 229         die "$0: undefined current object: $line" unless defined $symbols->{o};
 230         # 64-bit systems have 16 hexdigits, 32-bit systems have 8.
 231         if (s/^[0-9a-f]{8}(?:[0-9a-f]{8})? //) {
 232             # String literals can live in different sections
 233             # depending on the compiler and os release, assumedly
 234             # also linker flags.
 235             if (/^\(__TEXT,__(?:const|cstring|literal\d+)\) (?:non-)?external _?(\w+)(\.\w+)?$/) {
 236                 my ($symbol, $suffix) = ($1, $2);
 237                 # Ignore function-local constants like
 238                 # _Perl_av_extend_guts.oom_array_extend
 239                 return if defined $suffix && /__TEXT,__const/;
 240                 # Ignore the cstring unnamed strings.
 241                 return if $symbol =~ /^L\.str\d+$/;
 242                 $symbols->{data}{const}{$symbol}{$symbols->{o}}++;
 243             } elsif (/^\(__TEXT,__text\) (?:non-)?external _(\w+)$/) {
 244                 $symbols->{text}{$1}{$symbols->{o}}++;
 245             } elsif (/^\(__DATA,__(const|data|bss|common)\) (?:non-)?external _(\w+)(\.\w+)?$/) {
 246                 my ($dtype, $symbol, $suffix) = ($1, $2, $3);
 247                 # Ignore function-local constants like
 248                 # _Perl_pp_gmtime.dayname
 249                 return if defined $suffix;
 250                 $symbols->{data}{$dtype}{$symbol}{$symbols->{o}}++;
 251             } elsif (/^\(__DATA,__const\) non-external _\.memset_pattern\d*$/) {
 252                 # Skip this, whatever it is (some inlined leakage from
 253                 # darwin libc?)
 254             } elsif (/^\(__TEXT,__eh_frame/) {
 255                 # Skip the eh_frame (exception handling) symbols.
 256                 return;
 257             } elsif (/^\(__\w+,__\w+\) /) {
 258                 # Skip the unknown types.
 259                 print "# Unknown type: $line ($symbols->{o})\n";
 260             }
 261             return;
 262         } elsif (/^ {8}(?: {8})? \(undefined(?: \[lazy bound\])?\) external _?(.+)/) {
 263             # darwin/ppc marks most undefined text symbols
 264             # as "[lazy bound]".
 265             my ($symbol) = $1;
 266             return if is_perlish_symbol($symbol);
 267             $symbols->{undef}{$symbol}{$symbols->{o}}++;
 268             return;
 269         }
 270     }
 271     print "# Unexpected nm output '$line' ($symbols->{o})\n";
 272 }
 273
 274 my $nm_parse;
 275
 276 if ($nm_style eq 'gnu') {
 277     $nm_parse = \&nm_parse_gnu;
 278 } elsif ($nm_style eq 'darwin') {
 279     $nm_parse = \&nm_parse_darwin;
 280 }
 281
 282 unless (defined $nm_parse) {
 283     skip_all "no nm parser ($nm_style $nm_style, \$^O $^O)";
 284 }
 285
 286 my %symbols;
 287
 288 while (<$nm_fh>) {
 289     next if /^$/;
 290     chomp;
 291     $nm_parse->(\%symbols);
 292 }
 293
 294 # use Data::Dumper; print Dumper(\%symbols);
 295
 296 if (keys %symbols == 0) {
 297     skip_all "no symbols\n";
 298 }
 299
 300 # These should always be true for everyone.
 301
 302 ok($symbols{obj}{'pp.o'}, "has object pp.o");
 303 ok($symbols{text}{'Perl_peep'}, "has text Perl_peep");
 304 ok($symbols{text}{'Perl_pp_uc'}{'pp.o'}, "has text Perl_pp_uc in pp.o");
 305 ok(exists $symbols{data}{const}, "has data const symbols");
 306 ok($symbols{data}{const}{PL_no_mem}{'globals.o'}, "has PL_no_mem");
 307
 308 my $DEBUGGING = $Config{ccflags} =~ /-DDEBUGGING/ ? 1 : 0;
 309
 310 my $GS  = $Config{ccflags} =~ /-DPERL_GLOBAL_STRUCT\b/ ? 1 : 0;
 311 my $GSP = $Config{ccflags} =~ /-DPERL_GLOBAL_STRUCT_PRIVATE/ ? 1 : 0;
 312
 313 print "# GS  = $GS\n";
 314 print "# GSP = $GSP\n";
 315
 316 my %data_symbols;
 317
 318 for my $dtype (sort keys %{$symbols{data}}) {
 319     for my $symbol (sort keys %{$symbols{data}{$dtype}}) {
 320         $data_symbols{$symbol}++;
 321     }
 322 }
 323
 324 # The following tests differ between vanilla vs $GSP or $GS.
 325
 326 if ($GSP) {
 327     print "# -DPERL_GLOBAL_STRUCT_PRIVATE\n";
 328     ok(!exists $data_symbols{PL_hash_seed}, "has no PL_hash_seed");
 329     ok(!exists $data_symbols{PL_ppaddr}, "has no PL_ppaddr");
 330
 331     ok(! exists $symbols{data}{bss}, "has no data bss symbols");
 332     ok(! exists $symbols{data}{data} ||
 333             # clang with ASAN seems to add this symbol to every object file:
 334             !grep($_ ne '__unnamed_1', keys %{$symbols{data}{data}}),
 335         "has no data data symbols");
 336     ok(! exists $symbols{data}{common}, "has no data common symbols");
 337
 338     # -DPERL_GLOBAL_STRUCT_PRIVATE should NOT have
 339     # the extra text symbol for accessing the vars
 340     # (as opposed to "just" -DPERL_GLOBAL_STRUCT)
 341     ok(! exists $symbols{text}{Perl_GetVars}, "has no Perl_GetVars");
 342 } elsif ($GS) {
 343     print "# -DPERL_GLOBAL_STRUCT\n";
 344     ok(!exists $data_symbols{PL_hash_seed}, "has no PL_hash_seed");
 345     ok(!exists $data_symbols{PL_ppaddr}, "has no PL_ppaddr");
 346
 347     ok(! exists $symbols{data}{bss}, "has no data bss symbols");
 348
 349     # These PerlIO data symbols are left visible with
 350     # -DPERL_GLOBAL_STRUCT (as opposed to -DPERL_GLOBAL_STRUCT_PRIVATE)
 351     my @PerlIO =
 352         qw(
 353            PerlIO_byte
 354            PerlIO_crlf
 355            PerlIO_pending
 356            PerlIO_perlio
 357            PerlIO_raw
 358            PerlIO_remove
 359            PerlIO_stdio
 360            PerlIO_unix
 361            PerlIO_utf8
 362           );
 363
 364     # PL_magic_vtables is const with -DPERL_GLOBAL_STRUCT_PRIVATE but
 365     # otherwise not const -- because of SWIG which wants to modify
 366     # the table.  Evil SWIG, eeevil.
 367
 368     # my_cxt_index is used with PERL_IMPLICIT_CONTEXT, which
 369     # -DPERL_GLOBAL_STRUCT has turned on.
 370     eq_array([sort keys %{$symbols{data}{data}}],
 371              [sort('PL_VarsPtr',
 372                    @PerlIO,
 373                    'PL_magic_vtables',
 374                    'my_cxt_index')],
 375              "data data symbols");
 376
 377     # Only one data common symbol, our "supervariable".
 378     eq_array([sort keys %{$symbols{data}{common}}],
 379              ['PL_Vars'],
 380              "data common symbols");
 381
 382     ok($symbols{data}{data}{PL_VarsPtr}{'globals.o'}, "has PL_VarsPtr");
 383     ok($symbols{data}{common}{PL_Vars}{'globals.o'}, "has PL_Vars");
 384
 385     # -DPERL_GLOBAL_STRUCT has extra text symbol for accessing the vars.
 386     ok($symbols{text}{Perl_GetVars}{'util.o'}, "has Perl_GetVars");
 387 } else {
 388     print "# neither -DPERL_GLOBAL_STRUCT nor -DPERL_GLOBAL_STRUCT_PRIVATE\n";
 389
 390     if ( !$symbols{data}{common} ) {
 391         # This is likely because Perl was compiled with
 392         # -Accflags="-fno-common"
 393         $symbols{data}{common} = $symbols{data}{bss};
 394     }
 395
 396     ok($symbols{data}{common}{PL_hash_seed}{'globals.o'}, "has PL_hash_seed");
 397     ok($symbols{data}{data}{PL_ppaddr}{'globals.o'}, "has PL_ppaddr");
 398
 399     # None of the GLOBAL_STRUCT* business here.
 400     ok(! exists $symbols{data}{data}{PL_VarsPtr}, "has no PL_VarsPtr");
 401     ok(! exists $symbols{data}{common}{PL_Vars}, "has no PL_Vars");
 402     ok(! exists $symbols{text}{Perl_GetVars}, "has no Perl_GetVars");
 403 }
 404
 405 ok(keys %{$symbols{undef}}, "has undefined symbols");
 406
 407 my @good = qw(memchr memcmp memcpy chmod socket getenv sigaction sqrt time);
 408 if ($Config{usedl}) {
 409     push @good, 'dlopen';
 410 }
 411 for my $good (@good) {
 412     my @o = exists $symbols{undef}{$good} ?
 413         sort keys %{ $symbols{undef}{$good} } : ();
 414     ok(@o, "uses $good (@o)");
 415 }
 416
 417 my @bad = qw(gets strcpy strcat strncpy strncat sprintf vsprintf);
 418 # XXX: add atoi() to @bad
 419 for my $bad (@bad) {
 420     my @o = exists $symbols{undef}{$bad} ?
 421         sort keys %{ $symbols{undef}{$bad} } : ();
 422     is(@o, 0, "uses no $bad (@o)");
 423 }
 424
 425 if (defined $nm_err_tmp) {
 426     if (open(my $nm_err_fh, $nm_err_tmp)) {
 427         my $error;
 428         while (<$nm_err_fh>) {
 429             # OS X has weird error where nm warns about
 430             # "no name list" but then outputs fine.
 431             if (/nm: no name list/ && $^O eq 'darwin') {
 432                 print "# $^O ignoring $nm output: $_";
 433                 next;
 434             }
 435             warn "$0: Unexpected $nm error: $_";
 436             $error++;
 437         }
 438         die "$0: Unexpected $nm errors\n" if $error;
 439     } else {
 440         warn "Failed to open '$nm_err_tmp': $!\n";
 441     }
 442 }
 443
 444 done_testing();