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