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