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