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     VMS         => { writer     => \&writer_VMS,
 121                      sort       => OpenSSL::Ordinals::by_number(),
 122                      platforms  => { VMS                        => 1 } },
 123     vms         => 'VMS',       # alias
 124     WINDOWS     => { writer     => \&writer_windows,
 125                      sort       => OpenSSL::Ordinals::by_name(),
 126                      platforms  => { WIN32                      => 1,
 127                                      _WIN32                     => 1 } },
 128     windows     => 'WINDOWS',   # alias
 129     WIN32       => 'WINDOWS',   # alias
 130     win32       => 'WIN32',     # alias
 131     32          => 'WIN32',     # alias
 132     NT          => 'WIN32',     # alias
 133     nt          => 'WIN32',     # alias
 134     mingw       => 'WINDOWS',   # alias
 135     nonstop     => { writer     => \&writer_nonstop,
 136                      sort       => OpenSSL::Ordinals::by_name(),
 137                      platforms  => { TANDEM                     => 1 } },
 138    );
 139
 140 do {
 141     die "Unknown operating system family $OS\n"
 142         unless exists $OS_data{$OS};
 143     $OS = $OS_data{$OS};
 144 } while(ref($OS) eq '');
 145
 146 my %disabled_uc = map { my $x = uc $_; $x =~ s|-|_|g; $x => 1 } keys %disabled;
 147
 148 my %ordinal_opts = ();
 149 $ordinal_opts{sort} = $OS->{sort} if $OS->{sort};
 150 $ordinal_opts{filter} =
 151     sub {
 152         my $item = shift;
 153         return
 154             $item->exists()
 155             && platform_filter($item)
 156             && feature_filter($item);
 157     };
 158 my $ordinals = OpenSSL::Ordinals->new(from => $ordinals_file);
 159
 160 my $writer = $OS->{writer};
 161 $writer = \&writer_ctest if $ctest;
 162
 163 $writer->($ordinals->items(%ordinal_opts));
 164
 165 exit 0;
 166
 167 sub platform_filter {
 168     my $item = shift;
 169     my %platforms = ( $item->platforms() );
 170
 171     # True if no platforms are defined
 172     return 1 if scalar keys %platforms == 0;
 173
 174     # For any item platform tag, return the equivalence with the
 175     # current platform settings if it exists there, return 0 otherwise
 176     # if the item platform tag is true
 177     for (keys %platforms) {
 178         if (exists $OS->{platforms}->{$_}) {
 179             return $platforms{$_} == $OS->{platforms}->{$_};
 180         }
 181         if ($platforms{$_}) {
 182             return 0;
 183         }
 184     }
 185
 186     # Found no match?  Then it's a go
 187     return 1;
 188 }
 189
 190 sub feature_filter {
 191     my $item = shift;
 192     my @features = ( $item->features() );
 193
 194     # True if no features are defined
 195     return 1 if scalar @features == 0;
 196
 197     my $verdict = ! grep { $disabled_uc{$_} } @features;
 198
 199     if ($disabled{deprecated}) {
 200         foreach (@features) {
 201             next unless /^DEPRECATEDIN_(\d+)_(\d+)(?:_(\d+))?$/;
 202             my $symdep = $1 * 10000 + $2 * 100 + ($3 // 0);
 203             $verdict = 0 if $config{api} >= $symdep;
 204             print STDERR "DEBUG: \$symdep = $symdep, \$verdict = $verdict\n"
 205                 if $debug && $1 == 0;
 206         }
 207     }
 208
 209     return $verdict;
 210 }
 211
 212 sub sorter_unix {
 213     my $by_name = OpenSSL::Ordinals::by_name();
 214     my %weight = (
 215         'FUNCTION'      => 1,
 216         'VARIABLE'      => 2
 217        );
 218
 219     return sub {
 220         my $item1 = shift;
 221         my $item2 = shift;
 222
 223         my $verdict = $weight{$item1->type()} <=> $weight{$item2->type()};
 224         if ($verdict == 0) {
 225             $verdict = $by_name->($item1, $item2);
 226         }
 227         return $verdict;
 228     };
 229 }
 230
 231 sub sorter_linux {
 232     my $by_version = OpenSSL::Ordinals::by_version();
 233     my $by_unix = sorter_unix();
 234
 235     return sub {
 236         my $item1 = shift;
 237         my $item2 = shift;
 238
 239         my $verdict = $by_version->($item1, $item2);
 240         if ($verdict == 0) {
 241             $verdict = $by_unix->($item1, $item2);
 242         }
 243         return $verdict;
 244     };
 245 }
 246
 247 sub writer_linux {
 248     my $thisversion = '';
 249     my $currversion_s = '';
 250     my $prevversion_s = '';
 251     my $indent = 0;
 252
 253     for (@_) {
 254         if ($thisversion && $_->version() ne $thisversion) {
 255             die "$ordinals_file: It doesn't make sense to have both versioned ",
 256                 "and unversioned symbols"
 257                 if $thisversion eq '*';
 258             print <<"_____";
 259 }${prevversion_s};
 260 _____
 261             $prevversion_s = " OPENSSL${SO_VARIANT}_$thisversion";
 262             $thisversion = '';  # Trigger start of next section
 263         }
 264         unless ($thisversion) {
 265             $indent = 0;
 266             $thisversion = $_->version();
 267             $currversion_s = '';
 268             $currversion_s = "OPENSSL${SO_VARIANT}_$thisversion "
 269                 if $thisversion ne '*';
 270             print <<"_____";
 271 ${currversion_s}{
 272     global:
 273 _____
 274         }
 275         print '        ', $_->name(), ";\n";
 276     }
 277
 278     print <<"_____";
 279     local: *;
 280 }${prevversion_s};
 281 _____
 282 }
 283
 284 sub writer_aix {
 285     for (@_) {
 286         print $_->name(),"\n";
 287     }
 288 }
 289
 290 sub writer_nonstop {
 291     for (@_) {
 292         print "-export ",$_->name(),"\n";
 293     }
 294 }
 295
 296 sub writer_windows {
 297     print <<"_____";
 298 ;
 299 ; Definition file for the DLL version of the $libname library from OpenSSL
 300 ;
 301
 302 LIBRARY         "$libname"
 303
 304 EXPORTS
 305 _____
 306     for (@_) {
 307         print "    ",$_->name();
 308         if (platform->can('export2internal')) {
 309             print "=". platform->export2internal($_->name());
 310         }
 311         print "\n";
 312     }
 313 }
 314
 315 sub collect_VMS_mixedcase {
 316     return [ 'SPARE', 'SPARE' ] unless @_;
 317
 318     my $s = shift;
 319     my $s_uc = uc($s);
 320     my $type = shift;
 321
 322     return [ "$s=$type", 'SPARE' ] if $s_uc eq $s;
 323     return [ "$s_uc/$s=$type", "$s=$type" ];
 324 }
 325
 326 sub collect_VMS_uppercase {
 327     return [ 'SPARE' ] unless @_;
 328
 329     my $s = shift;
 330     my $s_uc = uc($s);
 331     my $type = shift;
 332
 333     return [ "$s_uc=$type" ];
 334 }
 335
 336 sub writer_VMS {
 337     my @slot_collection = ();
 338     my $collector =
 339         $case_insensitive ? \&collect_VMS_uppercase : \&collect_VMS_mixedcase;
 340
 341     my $last_num = 0;
 342     foreach (@_) {
 343         my $this_num = $_->number();
 344         $this_num = $last_num + 1 if $this_num =~ m|^\?|;
 345
 346         while (++$last_num < $this_num) {
 347             push @slot_collection, $collector->(); # Just occupy a slot
 348         }
 349         my $type = {
 350             FUNCTION    => 'PROCEDURE',
 351             VARIABLE    => 'DATA'
 352            } -> {$_->type()};
 353         push @slot_collection, $collector->($_->name(), $type);
 354     }
 355
 356     print <<"_____" if defined $version;
 357 IDENTIFICATION=$version
 358 _____
 359     print <<"_____" unless $case_insensitive;
 360 CASE_SENSITIVE=YES
 361 _____
 362     print <<"_____";
 363 SYMBOL_VECTOR=(-
 364 _____
 365     # It's uncertain how long aggregated lines the linker can handle,
 366     # but it has been observed that at least 1024 characters is ok.
 367     # Either way, this means that we need to keep track of the total
 368     # line length of each "SYMBOL_VECTOR" statement.  Fortunately, we
 369     # can have more than one of those...
 370     my $symvtextcount = 16;     # The length of "SYMBOL_VECTOR=("
 371     while (@slot_collection) {
 372         my $set = shift @slot_collection;
 373         my $settextlength = 0;
 374         foreach (@$set) {
 375             $settextlength +=
 376                 + 3             # two space indentation and comma
 377                 + length($_)
 378                 + 1             # postdent
 379                 ;
 380         }
 381         $settextlength--;       # only one space indentation on the first one
 382         my $firstcomma = ',';
 383
 384         if ($symvtextcount + $settextlength > 1024) {
 385             print <<"_____";
 386 )
 387 SYMBOL_VECTOR=(-
 388 _____
 389             $symvtextcount = 16; # The length of "SYMBOL_VECTOR=("
 390         }
 391         if ($symvtextcount == 16) {
 392             $firstcomma = '';
 393         }
 394
 395         my $indent = ' '.$firstcomma;
 396         foreach (@$set) {
 397             print <<"_____";
 398 $indent$_ -
 399 _____
 400             $symvtextcount += length($indent) + length($_) + 1;
 401             $indent = '  ,';
 402         }
 403     }
 404     print <<"_____";
 405 )
 406 _____
 407
 408     if (defined $version) {
 409         $version =~ /^(\d+)\.(\d+)\.(\d+)/;
 410         my $libvmajor = $1;
 411         my $libvminor = $2 * 100 + $3;
 412         print <<"_____";
 413 GSMATCH=LEQUAL,$libvmajor,$libvminor
 414 _____
 415     }
 416 }
 417
 418 sub writer_ctest {
 419     print <<'_____';
 420 /*
 421  * Test file to check all DEF file symbols are present by trying
 422  * to link to all of them. This is *not* intended to be run!
 423  */
 424
 425 int main()
 426 {
 427 _____
 428
 429     my $last_num = 0;
 430     for (@_) {
 431         my $this_num = $_->number();
 432         $this_num = $last_num + 1 if $this_num =~ m|^\?|;
 433
 434         if ($_->type() eq 'VARIABLE') {
 435             print "\textern int ", $_->name(), '; /* type unknown */ /* ',
 436                   $this_num, ' ', $_->version(), " */\n";
 437         } else {
 438             print "\textern int ", $_->name(), '(); /* type unknown */ /* ',
 439                   $this_num, ' ', $_->version(), " */\n";
 440         }
 441
 442         $last_num = $this_num;
 443     }
 444     print <<'_____';
 445 }
 446 _____
 447 }