#! /usr/bin/env perl
# Copyright 2018-2021 The OpenSSL Project Authors. All Rights Reserved.
#
# Licensed under the Apache License 2.0 (the "License").  You may not use
# this file except in compliance with the License.  You can obtain a copy
# in the file LICENSE in the source distribution or at
# https://www.openssl.org/source/license.html

# Generate a linker version script suitable for the given platform
# from a given ordinals file.

use strict;
use warnings;

use Getopt::Long;
use FindBin;
use lib "$FindBin::Bin/perl";

use OpenSSL::Ordinals;

use lib '.';
use configdata;

use File::Spec::Functions;
use lib catdir($config{sourcedir}, 'Configurations');
use platform;

my $name = undef;               # internal library/module name
my $ordinals_file = undef;      # the ordinals file to use
my $version = undef;            # the version to use for the library
my $OS = undef;                 # the operating system family
my $verbose = 0;
my $ctest = 0;
my $debug = 0;

# For VMS, some modules may have case insensitive names
my $case_insensitive = 0;

GetOptions('name=s'     => \$name,
           'ordinals=s' => \$ordinals_file,
           'version=s'  => \$version,
           'OS=s'       => \$OS,
           'ctest'      => \$ctest,
           'verbose'    => \$verbose,
           # For VMS
           'case-insensitive' => \$case_insensitive)
    or die "Error in command line arguments\n";

die "Please supply arguments\n"
    unless $name && $ordinals_file && $OS;

# When building a "variant" shared library, with a custom SONAME, also customize
# all the symbol versions.  This produces a shared object that can coexist
# without conflict in the same address space as a default build, or an object
# with a different variant tag.
#
# For example, with a target definition that includes:
#
#         shlib_variant => "-opt",
#
# we build the following objects:
#
# $ perl -le '
#     for (@ARGV) {
#         if ($l = readlink) {
#             printf "%s -> %s\n", $_, $l
#         } else {
#             print
#         }
#     }' *.so*
# libcrypto-opt.so.1.1
# libcrypto.so -> libcrypto-opt.so.1.1
# libssl-opt.so.1.1
# libssl.so -> libssl-opt.so.1.1
#
# whose SONAMEs and dependencies are:
#
# $ for l in *.so; do
#     echo $l
#     readelf -d $l | egrep 'SONAME|NEEDED.*(ssl|crypto)'
#   done
# libcrypto.so
#  0x000000000000000e (SONAME)             Library soname: [libcrypto-opt.so.1.1]
# libssl.so
#  0x0000000000000001 (NEEDED)             Shared library: [libcrypto-opt.so.1.1]
#  0x000000000000000e (SONAME)             Library soname: [libssl-opt.so.1.1]
#
# We case-fold the variant tag to upper case and replace all non-alnum
# characters with "_".  This yields the following symbol versions:
#
# $ nm libcrypto.so | grep -w A
# 0000000000000000 A OPENSSL_OPT_1_1_0
# 0000000000000000 A OPENSSL_OPT_1_1_0a
# 0000000000000000 A OPENSSL_OPT_1_1_0c
# 0000000000000000 A OPENSSL_OPT_1_1_0d
# 0000000000000000 A OPENSSL_OPT_1_1_0f
# 0000000000000000 A OPENSSL_OPT_1_1_0g
# $ nm libssl.so | grep -w A
# 0000000000000000 A OPENSSL_OPT_1_1_0
# 0000000000000000 A OPENSSL_OPT_1_1_0d
#
(my $SO_VARIANT = uc($target{"shlib_variant"} // '')) =~ s/\W/_/g;

my $libname = platform->sharedname($name);

my %OS_data = (
    solaris     => { writer     => \&writer_linux,
                     sort       => sorter_linux(),
                     platforms  => { UNIX                       => 1 } },
    "solaris-gcc" => 'solaris', # alias
    linux       => 'solaris',   # alias
    "bsd-gcc"   => 'solaris',   # alias
    aix         => { writer     => \&writer_aix,
                     sort       => sorter_unix(),
                     platforms  => { UNIX                       => 1 } },
    VMS         => { writer     => \&writer_VMS,
                     sort       => OpenSSL::Ordinals::by_number(),
                     platforms  => { VMS                        => 1 } },
    vms         => 'VMS',       # alias
    WINDOWS     => { writer     => \&writer_windows,
                     sort       => OpenSSL::Ordinals::by_name(),
                     platforms  => { WIN32                      => 1,
                                     _WIN32                     => 1 } },
    windows     => 'WINDOWS',   # alias
    WIN32       => 'WINDOWS',   # alias
    win32       => 'WIN32',     # alias
    32          => 'WIN32',     # alias
    NT          => 'WIN32',     # alias
    nt          => 'WIN32',     # alias
    mingw       => 'WINDOWS',   # alias
    nonstop     => { writer     => \&writer_nonstop,
                     sort       => OpenSSL::Ordinals::by_name(),
                     platforms  => { TANDEM                     => 1 } },
   );

do {
    die "Unknown operating system family $OS\n"
        unless exists $OS_data{$OS};
    $OS = $OS_data{$OS};
} while(ref($OS) eq '');

my %disabled_uc = map { my $x = uc $_; $x =~ s|-|_|g; $x => 1 } keys %disabled;

my %ordinal_opts = ();
$ordinal_opts{sort} = $OS->{sort} if $OS->{sort};
$ordinal_opts{filter} =
    sub {
        my $item = shift;
        return
            $item->exists()
            && platform_filter($item)
            && feature_filter($item);
    };
my $ordinals = OpenSSL::Ordinals->new(from => $ordinals_file);

my $writer = $OS->{writer};
$writer = \&writer_ctest if $ctest;

$writer->($ordinals->items(%ordinal_opts));

exit 0;

sub platform_filter {
    my $item = shift;
    my %platforms = ( $item->platforms() );

    # True if no platforms are defined
    return 1 if scalar keys %platforms == 0;

    # For any item platform tag, return the equivalence with the
    # current platform settings if it exists there, return 0 otherwise
    # if the item platform tag is true
    for (keys %platforms) {
        if (exists $OS->{platforms}->{$_}) {
            return $platforms{$_} == $OS->{platforms}->{$_};
        }
        if ($platforms{$_}) {
            return 0;
        }
    }

    # Found no match?  Then it's a go
    return 1;
}

sub feature_filter {
    my $item = shift;
    my @features = ( $item->features() );

    # True if no features are defined
    return 1 if scalar @features == 0;

    my $verdict = ! grep { $disabled_uc{$_} } @features;

    if ($disabled{deprecated}) {
        foreach (@features) {
            next unless /^DEPRECATEDIN_(\d+)_(\d+)(?:_(\d+))?$/;
            my $symdep = $1 * 10000 + $2 * 100 + ($3 // 0);
            $verdict = 0 if $config{api} >= $symdep;
            print STDERR "DEBUG: \$symdep = $symdep, \$verdict = $verdict\n"
                if $debug && $1 == 0;
        }
    }

    return $verdict;
}

sub sorter_unix {
    my $by_name = OpenSSL::Ordinals::by_name();
    my %weight = (
        'FUNCTION'      => 1,
        'VARIABLE'      => 2
       );

    return sub {
        my $item1 = shift;
        my $item2 = shift;

        my $verdict = $weight{$item1->type()} <=> $weight{$item2->type()};
        if ($verdict == 0) {
            $verdict = $by_name->($item1, $item2);
        }
        return $verdict;
    };
}

sub sorter_linux {
    my $by_version = OpenSSL::Ordinals::by_version();
    my $by_unix = sorter_unix();

    return sub {
        my $item1 = shift;
        my $item2 = shift;

        my $verdict = $by_version->($item1, $item2);
        if ($verdict == 0) {
            $verdict = $by_unix->($item1, $item2);
        }
        return $verdict;
    };
}

sub writer_linux {
    my $thisversion = '';
    my $currversion_s = '';
    my $prevversion_s = '';
    my $indent = 0;

    for (@_) {
        if ($thisversion && $_->version() ne $thisversion) {
            die "$ordinals_file: It doesn't make sense to have both versioned ",
                "and unversioned symbols"
                if $thisversion eq '*';
            print <<"_____";
}${prevversion_s};
_____
            $prevversion_s = " OPENSSL${SO_VARIANT}_$thisversion";
            $thisversion = '';  # Trigger start of next section
        }
        unless ($thisversion) {
            $indent = 0;
            $thisversion = $_->version();
            $currversion_s = '';
            $currversion_s = "OPENSSL${SO_VARIANT}_$thisversion "
                if $thisversion ne '*';
            print <<"_____";
${currversion_s}{
    global:
_____
        }
        print '        ', $_->name(), ";\n";
    }

    print <<"_____";
    local: *;
}${prevversion_s};
_____
}

sub writer_aix {
    for (@_) {
        print $_->name(),"\n";
    }
}

sub writer_nonstop {
    for (@_) {
        print "-export ",$_->name(),"\n";
    }
}

sub writer_windows {
    print <<"_____";
;
; Definition file for the DLL version of the $libname library from OpenSSL
;

LIBRARY         "$libname"

EXPORTS
_____
    for (@_) {
        print "    ",$_->name();
        if (platform->can('export2internal')) {
            print "=". platform->export2internal($_->name());
        }
        print "\n";
    }
}

sub collect_VMS_mixedcase {
    return [ 'SPARE', 'SPARE' ] unless @_;

    my $s = shift;
    my $s_uc = uc($s);
    my $type = shift;

    return [ "$s=$type", 'SPARE' ] if $s_uc eq $s;
    return [ "$s_uc/$s=$type", "$s=$type" ];
}

sub collect_VMS_uppercase {
    return [ 'SPARE' ] unless @_;

    my $s = shift;
    my $s_uc = uc($s);
    my $type = shift;

    return [ "$s_uc=$type" ];
}

sub writer_VMS {
    my @slot_collection = ();
    my $collector =
        $case_insensitive ? \&collect_VMS_uppercase : \&collect_VMS_mixedcase;

    my $last_num = 0;
    foreach (@_) {
        my $this_num = $_->number();
        $this_num = $last_num + 1 if $this_num =~ m|^\?|;

        while (++$last_num < $this_num) {
            push @slot_collection, $collector->(); # Just occupy a slot
        }
        my $type = {
            FUNCTION    => 'PROCEDURE',
            VARIABLE    => 'DATA'
           } -> {$_->type()};
        push @slot_collection, $collector->($_->name(), $type);
    }

    print <<"_____" if defined $version;
IDENTIFICATION=$version
_____
    print <<"_____" unless $case_insensitive;
CASE_SENSITIVE=YES
_____
    print <<"_____";
SYMBOL_VECTOR=(-
_____
    # It's uncertain how long aggregated lines the linker can handle,
    # but it has been observed that at least 1024 characters is ok.
    # Either way, this means that we need to keep track of the total
    # line length of each "SYMBOL_VECTOR" statement.  Fortunately, we
    # can have more than one of those...
    my $symvtextcount = 16;     # The length of "SYMBOL_VECTOR=("
    while (@slot_collection) {
        my $set = shift @slot_collection;
        my $settextlength = 0;
        foreach (@$set) {
            $settextlength +=
                + 3             # two space indentation and comma
                + length($_)
                + 1             # postdent
                ;
        }
        $settextlength--;       # only one space indentation on the first one
        my $firstcomma = ',';

        if ($symvtextcount + $settextlength > 1024) {
            print <<"_____";
)
SYMBOL_VECTOR=(-
_____
            $symvtextcount = 16; # The length of "SYMBOL_VECTOR=("
        }
        if ($symvtextcount == 16) {
            $firstcomma = '';
        }

        my $indent = ' '.$firstcomma;
        foreach (@$set) {
            print <<"_____";
$indent$_ -
_____
            $symvtextcount += length($indent) + length($_) + 1;
            $indent = '  ,';
        }
    }
    print <<"_____";
)
_____

    if (defined $version) {
        $version =~ /^(\d+)\.(\d+)\.(\d+)/;
        my $libvmajor = $1;
        my $libvminor = $2 * 100 + $3;
        print <<"_____";
GSMATCH=LEQUAL,$libvmajor,$libvminor
_____
    }
}

sub writer_ctest {
    print <<'_____';
/*
 * Test file to check all DEF file symbols are present by trying
 * to link to all of them. This is *not* intended to be run!
 */

int main()
{
_____

    my $last_num = 0;
    for (@_) {
        my $this_num = $_->number();
        $this_num = $last_num + 1 if $this_num =~ m|^\?|;

        if ($_->type() eq 'VARIABLE') {
            print "\textern int ", $_->name(), '; /* type unknown */ /* ',
                  $this_num, ' ', $_->version(), " */\n";
        } else {
            print "\textern int ", $_->name(), '(); /* type unknown */ /* ',
                  $this_num, ' ', $_->version(), " */\n";
        }

        $last_num = $this_num;
    }
    print <<'_____';
}
_____
}