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