util/mkdef.pl

   1 #! /usr/bin/env perl
   2 # Copyright 2018-2021 The OpenSSL Project Authors. All Rights Reserved.
   3 #
   4 # Licensed under the Apache License 2.0 (the "License").  You may not use
   5 # this file except in compliance with the License.  You can obtain a copy
   6 # in the file LICENSE in the source distribution or at
   7 # https://www.openssl.org/source/license.html
   8
   9 # Generate a linker version script suitable for the given platform
  10 # from a given ordinals file.
  11
  12 use strict;
  13 use warnings;
  14
  15 use Getopt::Long;
  16 use FindBin;
  17 use lib "$FindBin::Bin/perl";
  18
  19 use OpenSSL::Ordinals;
  20
  21 use lib '.';
  22 use configdata;
  23
  24 use File::Spec::Functions;
  25 use lib catdir($config{sourcedir}, 'Configurations');
  26 use platform;
  27
  28 my $name = undef;               # internal library/module name
  29 my $ordinals_file = undef;      # the ordinals file to use
  30 my $version = undef;            # the version to use for the library
  31 my $OS = undef;                 # the operating system family
  32 my $type = 'lib';               # either lib or dso
  33 my $verbose = 0;
  34 my $ctest = 0;
  35 my $debug = 0;
  36
  37 # For VMS, some modules may have case insensitive names
  38 my $case_insensitive = 0;
  39
  40 GetOptions('name=s'     => \$name,
  41            'ordinals=s' => \$ordinals_file,
  42            'version=s'  => \$version,
  43            'OS=s'       => \$OS,
  44            'type=s'     => \$type,
  45            'ctest'      => \$ctest,
  46            'verbose'    => \$verbose,
  47            # For VMS
  48            'case-insensitive' => \$case_insensitive)
  49     or die "Error in command line arguments\n";
  50
  51 die "Please supply arguments\n"
  52     unless $name && $ordinals_file && $OS;
  53 die "--type argument must be equal to 'lib' or 'dso'"
  54     if $type ne 'lib' && $type ne 'dso';
  55
  56 # When building a "variant" shared library, with a custom SONAME, also customize
  57 # all the symbol versions.  This produces a shared object that can coexist
  58 # without conflict in the same address space as a default build, or an object
  59 # with a different variant tag.
  60 #
  61 # For example, with a target definition that includes:
  62 #
  63 #         shlib_variant => "-opt",
  64 #
  65 # we build the following objects:
  66 #
  67 # $ perl -le '
  68 #     for (@ARGV) {
  69 #         if ($l = readlink) {
  70 #             printf "%s -> %s\n", $_, $l
  71 #         } else {
  72 #             print
  73 #         }
  74 #     }' *.so*
  75 # libcrypto-opt.so.1.1
  76 # libcrypto.so -> libcrypto-opt.so.1.1
  77 # libssl-opt.so.1.1
  78 # libssl.so -> libssl-opt.so.1.1
  79 #
  80 # whose SONAMEs and dependencies are:
  81 #
  82 # $ for l in *.so; do
  83 #     echo $l
  84 #     readelf -d $l | egrep 'SONAME|NEEDED.*(ssl|crypto)'
  85 #   done
  86 # libcrypto.so
  87 #  0x000000000000000e (SONAME)             Library soname: [libcrypto-opt.so.1.1]
  88 # libssl.so
  89 #  0x0000000000000001 (NEEDED)             Shared library: [libcrypto-opt.so.1.1]
  90 #  0x000000000000000e (SONAME)             Library soname: [libssl-opt.so.1.1]
  91 #
  92 # We case-fold the variant tag to uppercase and replace all non-alnum
  93 # characters with "_".  This yields the following symbol versions:
  94 #
  95 # $ nm libcrypto.so | grep -w A
  96 # 0000000000000000 A OPENSSL_OPT_1_1_0
  97 # 0000000000000000 A OPENSSL_OPT_1_1_0a
  98 # 0000000000000000 A OPENSSL_OPT_1_1_0c
  99 # 0000000000000000 A OPENSSL_OPT_1_1_0d
 100 # 0000000000000000 A OPENSSL_OPT_1_1_0f
 101 # 0000000000000000 A OPENSSL_OPT_1_1_0g
 102 # $ nm libssl.so | grep -w A
 103 # 0000000000000000 A OPENSSL_OPT_1_1_0
 104 # 0000000000000000 A OPENSSL_OPT_1_1_0d
 105 #
 106 (my $SO_VARIANT = uc($target{"shlib_variant"} // '')) =~ s/\W/_/g;
 107
 108 my $libname = $type eq 'lib' ? platform->sharedname($name) : platform->dsoname($name);
 109
 110 my %OS_data = (
 111     solaris     => { writer     => \&writer_linux,
 112                      sort       => sorter_linux(),
 113                      platforms  => { UNIX                       => 1 } },
 114     "solaris-gcc" => 'solaris', # alias
 115     linux       => 'solaris',   # alias
 116     "bsd-gcc"   => 'solaris',   # alias
 117     aix         => { writer     => \&writer_aix,
 118                      sort       => sorter_unix(),
 119                      platforms  => { UNIX                       => 1 } },
 120     "aix-solib" => 'aix',       # alias
 121     VMS         => { writer     => \&writer_VMS,
 122                      sort       => OpenSSL::Ordinals::by_number(),
 123                      platforms  => { VMS                        => 1 } },
 124     vms         => 'VMS',       # alias
 125     WINDOWS     => { writer     => \&writer_windows,
 126                      sort       => OpenSSL::Ordinals::by_name(),
 127                      platforms  => { WIN32                      => 1,
 128                                      _WIN32                     => 1 } },
 129     windows     => 'WINDOWS',   # alias
 130     WIN32       => 'WINDOWS',   # alias
 131     win32       => 'WIN32',     # alias
 132     32          => 'WIN32',     # alias
 133     NT          => 'WIN32',     # alias
 134     nt          => 'WIN32',     # alias
 135     mingw       => 'WINDOWS',   # alias
 136     nonstop     => { writer     => \&writer_nonstop,
 137                      sort       => OpenSSL::Ordinals::by_name(),
 138                      platforms  => { TANDEM                     => 1 } },
 139    );
 140
 141 do {
 142     die "Unknown operating system family $OS\n"
 143         unless exists $OS_data{$OS};
 144     $OS = $OS_data{$OS};
 145 } while(ref($OS) eq '');
 146
 147 my %disabled_uc = map { my $x = uc $_; $x =~ s|-|_|g; $x => 1 } keys %disabled;
 148
 149 my %ordinal_opts = ();
 150 $ordinal_opts{sort} = $OS->{sort} if $OS->{sort};
 151 $ordinal_opts{filter} =
 152     sub {
 153         my $item = shift;
 154         return
 155             $item->exists()
 156             && platform_filter($item)
 157             && feature_filter($item);
 158     };
 159 my $ordinals = OpenSSL::Ordinals->new(from => $ordinals_file);
 160
 161 my $writer = $OS->{writer};
 162 $writer = \&writer_ctest if $ctest;
 163
 164 $writer->($ordinals->items(%ordinal_opts));
 165
 166 exit 0;
 167
 168 sub platform_filter {
 169     my $item = shift;
 170     my %platforms = ( $item->platforms() );
 171
 172     # True if no platforms are defined
 173     return 1 if scalar keys %platforms == 0;
 174
 175     # For any item platform tag, return the equivalence with the
 176     # current platform settings if it exists there, return 0 otherwise
 177     # if the item platform tag is true
 178     for (keys %platforms) {
 179         if (exists $OS->{platforms}->{$_}) {
 180             return $platforms{$_} == $OS->{platforms}->{$_};
 181         }
 182         if ($platforms{$_}) {
 183             return 0;
 184         }
 185     }
 186
 187     # Found no match?  Then it's a go
 188     return 1;
 189 }
 190
 191 sub feature_filter {
 192     my $item = shift;
 193     my @features = ( $item->features() );
 194
 195     # True if no features are defined
 196     return 1 if scalar @features == 0;
 197
 198     my $verdict = ! grep { $disabled_uc{$_} } @features;
 199
 200     if ($disabled{deprecated}) {
 201         foreach (@features) {
 202             next unless /^DEPRECATEDIN_(\d+)_(\d+)(?:_(\d+))?$/;
 203             my $symdep = $1 * 10000 + $2 * 100 + ($3 // 0);
 204             $verdict = 0 if $config{api} >= $symdep;
 205             print STDERR "DEBUG: \$symdep = $symdep, \$verdict = $verdict\n"
 206                 if $debug && $1 == 0;
 207         }
 208     }
 209
 210     return $verdict;
 211 }
 212
 213 sub sorter_unix {
 214     my $by_name = OpenSSL::Ordinals::by_name();
 215     my %weight = (
 216         'FUNCTION'      => 1,
 217         'VARIABLE'      => 2
 218        );
 219
 220     return sub {
 221         my $item1 = shift;
 222         my $item2 = shift;
 223
 224         my $verdict = $weight{$item1->type()} <=> $weight{$item2->type()};
 225         if ($verdict == 0) {
 226             $verdict = $by_name->($item1, $item2);
 227         }
 228         return $verdict;
 229     };
 230 }
 231
 232 sub sorter_linux {
 233     my $by_version = OpenSSL::Ordinals::by_version();
 234     my $by_unix = sorter_unix();
 235
 236     return sub {
 237         my $item1 = shift;
 238         my $item2 = shift;
 239
 240         my $verdict = $by_version->($item1, $item2);
 241         if ($verdict == 0) {
 242             $verdict = $by_unix->($item1, $item2);
 243         }
 244         return $verdict;
 245     };
 246 }
 247
 248 sub writer_linux {
 249     my $thisversion = '';
 250     my $currversion_s = '';
 251     my $prevversion_s = '';
 252     my $indent = 0;
 253
 254     for (@_) {
 255         if ($thisversion && $_->version() ne $thisversion) {
 256             die "$ordinals_file: It doesn't make sense to have both versioned ",
 257                 "and unversioned symbols"
 258                 if $thisversion eq '*';
 259             print <<"_____";
 260 }${prevversion_s};
 261 _____
 262             $prevversion_s = " OPENSSL${SO_VARIANT}_$thisversion";
 263             $thisversion = '';  # Trigger start of next section
 264         }
 265         unless ($thisversion) {
 266             $indent = 0;
 267             $thisversion = $_->version();
 268             $currversion_s = '';
 269             $currversion_s = "OPENSSL${SO_VARIANT}_$thisversion "
 270                 if $thisversion ne '*';
 271             print <<"_____";
 272 ${currversion_s}{
 273     global:
 274 _____
 275         }
 276         print '        ', $_->name(), ";\n";
 277     }
 278
 279     print <<"_____";
 280     local: *;
 281 }${prevversion_s};
 282 _____
 283 }
 284
 285 sub writer_aix {
 286     for (@_) {
 287         print $_->name(),"\n";
 288     }
 289 }
 290
 291 sub writer_nonstop {
 292     for (@_) {
 293         print "-export ",$_->name(),"\n";
 294     }
 295 }
 296
 297 sub writer_windows {
 298     print <<"_____";
 299 ;
 300 ; Definition file for the DLL version of the $libname library from OpenSSL
 301 ;
 302
 303 LIBRARY         "$libname"
 304
 305 EXPORTS
 306 _____
 307     for (@_) {
 308         print "    ",$_->name();
 309         if (platform->can('export2internal')) {
 310             print "=". platform->export2internal($_->name());
 311         }
 312         print "\n";
 313     }
 314 }
 315
 316 sub collect_VMS_mixedcase {
 317     return [ 'SPARE', 'SPARE' ] unless @_;
 318
 319     my $s = shift;
 320     my $s_uc = uc($s);
 321     my $type = shift;
 322
 323     return [ "$s=$type", 'SPARE' ] if $s_uc eq $s;
 324     return [ "$s_uc/$s=$type", "$s=$type" ];
 325 }
 326
 327 sub collect_VMS_uppercase {
 328     return [ 'SPARE' ] unless @_;
 329
 330     my $s = shift;
 331     my $s_uc = uc($s);
 332     my $type = shift;
 333
 334     return [ "$s_uc=$type" ];
 335 }
 336
 337 sub writer_VMS {
 338     my @slot_collection = ();
 339     my $collector =
 340         $case_insensitive ? \&collect_VMS_uppercase : \&collect_VMS_mixedcase;
 341
 342     my $last_num = 0;
 343     foreach (@_) {
 344         my $this_num = $_->number();
 345         $this_num = $last_num + 1 if $this_num =~ m|^\?|;
 346
 347         while (++$last_num < $this_num) {
 348             push @slot_collection, $collector->(); # Just occupy a slot
 349         }
 350         my $type = {
 351             FUNCTION    => 'PROCEDURE',
 352             VARIABLE    => 'DATA'
 353            } -> {$_->type()};
 354         push @slot_collection, $collector->($_->name(), $type);
 355     }
 356
 357     print <<"_____" if defined $version;
 358 IDENTIFICATION=$version
 359 _____
 360     print <<"_____" unless $case_insensitive;
 361 CASE_SENSITIVE=YES
 362 _____
 363     print <<"_____";
 364 SYMBOL_VECTOR=(-
 365 _____
 366     # It's uncertain how long aggregated lines the linker can handle,
 367     # but it has been observed that at least 1024 characters is ok.
 368     # Either way, this means that we need to keep track of the total
 369     # line length of each "SYMBOL_VECTOR" statement.  Fortunately, we
 370     # can have more than one of those...
 371     my $symvtextcount = 16;     # The length of "SYMBOL_VECTOR=("
 372     while (@slot_collection) {
 373         my $set = shift @slot_collection;
 374         my $settextlength = 0;
 375         foreach (@$set) {
 376             $settextlength +=
 377                 + 3             # two space indentation and comma
 378                 + length($_)
 379                 + 1             # postdent
 380                 ;
 381         }
 382         $settextlength--;       # only one space indentation on the first one
 383         my $firstcomma = ',';
 384
 385         if ($symvtextcount + $settextlength > 1024) {
 386             print <<"_____";
 387 )
 388 SYMBOL_VECTOR=(-
 389 _____
 390             $symvtextcount = 16; # The length of "SYMBOL_VECTOR=("
 391         }
 392         if ($symvtextcount == 16) {
 393             $firstcomma = '';
 394         }
 395
 396         my $indent = ' '.$firstcomma;
 397         foreach (@$set) {
 398             print <<"_____";
 399 $indent$_ -
 400 _____
 401             $symvtextcount += length($indent) + length($_) + 1;
 402             $indent = '  ,';
 403         }
 404     }
 405     print <<"_____";
 406 )
 407 _____
 408
 409     if (defined $version) {
 410         $version =~ /^(\d+)\.(\d+)\.(\d+)/;
 411         my $libvmajor = $1;
 412         my $libvminor = $2 * 100 + $3;
 413         print <<"_____";
 414 GSMATCH=LEQUAL,$libvmajor,$libvminor
 415 _____
 416     }
 417 }
 418
 419 sub writer_ctest {
 420     print <<'_____';
 421 /*
 422  * Test file to check all DEF file symbols are present by trying
 423  * to link to all of them. This is *not* intended to be run!
 424  */
 425
 426 int main()
 427 {
 428 _____
 429
 430     my $last_num = 0;
 431     for (@_) {
 432         my $this_num = $_->number();
 433         $this_num = $last_num + 1 if $this_num =~ m|^\?|;
 434
 435         if ($_->type() eq 'VARIABLE') {
 436             print "\textern int ", $_->name(), '; /* type unknown */ /* ',
 437                   $this_num, ' ', $_->version(), " */\n";
 438         } else {
 439             print "\textern int ", $_->name(), '(); /* type unknown */ /* ',
 440                   $this_num, ' ', $_->version(), " */\n";
 441         }
 442
 443         $last_num = $this_num;
 444     }
 445     print <<'_____';
 446 }
 447 _____
 448 }