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         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();