#!/usr/bin/perl

# Install Ada libraries from debian/tmp to their -dev and lib packages.
# Also helps /usr/share/ada/debian_packaging.mk.

# SPDX-License-Identifier: GPL-3.0+
# (GNU General Public License, version 3 or later at your convenience)
# Copyright (C) 2012-2023 Nicolas Boulenguez <nicolas@debian.org>

# This program is free software: you can redistribute it and/or
# modify it under the terms of the GNU General Public License as
# published by the Free Software Foundation, either version 3 of the
# License, or (at your option) any later version.
# This program is distributed in the hope that it will be useful, but
# WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
# General Public License for more details.
# You should have received a copy of the GNU General Public License
# along with this program. If not, see <http://www.gnu.org/licenses/>.

use autodie;
use feature qw( signatures state );
use re '/amsx';
use strict;
use warnings;

use Cwd;
use Debian::Debhelper::Dh_Lib;
use Dpkg::Control::Info;
use English '-no_match_vars';

# Initialization of Dh_Lib.
# The --export-versions option triggers a special mode for inclusion
# in packaging.mk by Ada packages, even if they build no library.
init(
    options => {
        'export-versions' => \$dh{EXPORT_VERSIONS},
    }
);

my $cwd = getcwd() or error("getcwd: $ERRNO");

# ----------------------------------------------------------------------
# Directories from the Debian Policy for Ada.

my $deb_ada_source_dir = 'usr/share/ada/adainclude';
my $deb_lib_dir = 'usr/lib/' . dpkg_architecture_value('DEB_HOST_MULTIARCH');
my $deb_ada_lib_info_dir = "$deb_lib_dir/ada/adalib";
my $deb_gnat_project_dir = 'usr/share/gpr';

my $deb_gnat_version = do {
    my @cmd = qw(gnatmake --version);
    my @out = qx_cmd(@cmd);             #_;# relax syntax highlighters
    if ( defined $out[0] and $out[0] =~ m/ [ ] (\d+) (?: [.] \d+ )* $ / ) {
        $1;
    }
    else {
        error('Failed to parse first line of gnatmake --version');
    }
};

# ----------------------------------------------------------------------
# Search for library packages in debian/control.

# Keys are library names.

my %dev_pkg;       # library -> lib($name with _ replaced with -)-dev
my %lib_pkg;       # library -> shared library package
my %so_version;    # library -> Shared Object version

for my $pkg ( getpackages('arch') ) {
    if ( $pkg =~ m/ ^ lib (.*) -dev $ / ) {

        # Ada packages and GNAT projects are case-insensitive and
        # allow underscores.
        # Deb package names are lowercase and allow dashes.
        my $name = $1 =~ tr/-/_/r;

        # A dash is inserted in the shared library package when the
        # name ends with a digit.
        my $lib_pattern = qr/ ^ lib $1 -? (\d+ (?: [.] \d+)*) $ /;

        # We need to parse debian/control again, with the more
        # accurate Dpkg library.  Do it at most once.
        state $control = Dpkg::Control::Info->new('debian/control');

        my $dpkg_pkg = $control->get_pkg_by_name($pkg);
        if ( exists $dpkg_pkg->{'Provides'}
            and $dpkg_pkg->{'Provides'} =~ m/ [$] [{] ada:Provides [}] / )
        {

            if ( not $dpkg_pkg->{'Depends'}
                or $dpkg_pkg->{'Depends'} !~ m/ [$] [{] ada:Depends [}] / )
            {
                error("$pkg uses ada:Provides but not ada:Depends");
            }

            # Find the matching shared library package.
            my $matches = 0;
            for my $lib_pkg ( getpackages('arch') ) {
                if ( $lib_pkg =~ $lib_pattern ) {
                    $matches += 1;
                    $lib_pkg{$name}    = $lib_pkg;
                    $so_version{$name} = $1;
                    $dev_pkg{$name}    = $pkg;
                }
            }
            if ( $matches != 1 ) {
                error("cannot find runtime package for $pkg");
            }
        }
    }
}

# ----------------------------------------------------------------------
# Special mode intended for inclusion in packaging.mk.

sub export_versions : prototype() () {

    print << "EOF" or error('print failed');
DEB_ADA_SOURCE_DIR:=$deb_ada_source_dir
DEB_LIB_DIR:=$deb_lib_dir
DEB_ADA_LIB_INFO_DIR:=$deb_ada_lib_info_dir
DEB_GNAT_PROJECT_DIR:=$deb_gnat_project_dir
DEB_GNAT_VERSION:=$deb_gnat_version
EOF

    for my $name ( keys %dev_pkg ) {

        print << "EOF" or error('print failed');
${name}_LIB_PKG:=$lib_pkg{$name}
${name}_SO_VERSION:=$so_version{$name}
EOF

    }
    return;
}

# ----------------------------------------------------------------------
# Install libraries.

sub extract_shared_object_name : prototype($) ($lib) {

    # See policy 8.1, note 3.
    my $objdump = dpkg_architecture_value('DEB_HOST_GNU_TYPE') . '-objdump';
    my @cmd     = ( $objdump, '-p', "debian/tmp/$deb_lib_dir/$lib" );
    my @out     = qx_cmd(@cmd);    #_;# relax syntax highlighters
    for my $line (@out) {
        if ( $line =~ m/ ^ [[:space:]]* SONAME [[:space:]]* ([\w.-]+) / ) {
            return $1;
        }
    }
    error('Failed to parse objdump output');
    return;
}

sub dev_owning_gpr : prototype($) ($gpr) {
    my @cmd = ( 'dpkg-query', '-S', "/$deb_gnat_project_dir/$gpr.gpr" );
    my @out = qx_cmd(@cmd);        #_;# relax syntax highlighters
    if ( @out == 1 and $out[0] =~ m/ (.*) : / ) {
        return $1;
    }
    return 0;
}

# Return the only virtual package provided by $dev_pkg named $prefix-HASH,
# where HASH contains 8 lowercaps hexadecimal digits.
# This function is intended for -dev packages (then $prefix equals $dev_pkg),
# but gnat-{13,14-HOST} also provide a -HASH virtual package.
# The checksums differ per architecture, so it is necessary to use the
# HOST version of the packages.
sub provided : prototype($$) ( $dev_pkg, $prefix ) {
    my $pattern = $dev_pkg . q{:} . dpkg_architecture_value('DEB_HOST_ARCH');
    my @cmd     = ( 'dpkg-query', '-Wf$' . '{Provides}', $pattern );
    my $out     = qx_cmd(@cmd);    #_;# relax syntax highlighters
    if ( $out !~ m/ ^ $prefix - [[:xdigit:]]{8} $ / ) {
        error("$dev_pkg must provide exactly one $prefix-HASH (got $out)");
    }
    return $out;
}

sub add_import_to_ada_depends : prototype($$) ( $name, $import ) {

    # Fresh packages take priority over installed versions.
    if ( exists $dev_pkg{$import} ) {

        # No need for a hash, we need the exact binary version anyway
        # because of static libraries.
        addsubstvar(
            $dev_pkg{$name},   'ada:Depends',
            $dev_pkg{$import}, '= $' . '{binary:Version}'
        );
    }
    elsif ( defined( my $dep = dev_owning_gpr($import) ) ) {

        # Hopefully the most frequent case.
        addsubstvar( $dev_pkg{$name}, 'ada:Depends', provided( $dep, $dep ) );
    }
    else {

        # Not an error, there may be non-library projects for example.
        warning("$name.gpr needs $import.gpr, no -dev package found");
    }
    return;
}

# We merge CRCs, so the usual inconvenients of xor do not apply.
# Roughly 2**16 ~ 66k uploads before first collision.
# Should be in sync with debian/ada/gencontrol_arg in the gcc package.
sub checksum : prototype(@) (@ali_files) {
    my $result = 0;
    for my $path (@ali_files) {
        open my $fh, q{<}, $path;
        while (<$fh>) {
            if (m/ ^ D [ ] [^\t]+ \t+ \d{14} [ ] ( [[:xdigit:]]{8} ) /) {
                $result ^= hex $1;
            }
        }
        close $fh;
    }
    return sprintf '%08x', $result;
}

sub process_dev_package_and_not_installed : prototype($) ($name) {

    # ALI files
    my $ali_glob  = "debian/tmp/$deb_ada_lib_info_dir/$name/*.ali";
    my @ali_files = glob $ali_glob;

    # Sources
    my $src_glob  = "debian/tmp/$deb_ada_source_dir/$name/*";
    my @src_files = glob $src_glob;

    # Static archive
    my $a = "debian/tmp/$deb_lib_dir/lib$name.a";

    # Project
    my $gpr = "debian/tmp/$deb_gnat_project_dir/$name.gpr";

    # Development symbolic link
    my $so = "debian/tmp/$deb_lib_dir/lib$name.so";

    # Static files unwantedly added by gprinstall.
    # (optional)
    # They are logged for each -dev package, but this does not seem to hurt.
    my $gprtrash = 'debian/tmp/usr/unwantedly_gprinstalled';

    # Libtool .la file
    # (optional)
    my $la = "debian/tmp/$deb_lib_dir/lib$name.la";

    log_installed_files( $dev_pkg{$name}, @ali_files, @src_files, $a, $gpr,
        $so, $gprtrash, $la );

    if ( process_pkg( $dev_pkg{$name} ) ) {
        my $tmpdir = tmpdir( $dev_pkg{$name} );

        install_dir(
            "$tmpdir/$deb_ada_lib_info_dir/$name",
            "$tmpdir/$deb_ada_source_dir/$name",
            "$tmpdir/$deb_gnat_project_dir",
            "$tmpdir/$deb_lib_dir",
        );

        # Install required files.
        @ali_files or error("$ali_glob are missing");
        @src_files or error("$src_glob are missing");
        -l $so     or error("$so is missing or not a symbolic link");
        for my $path ( @ali_files, @src_files, $gpr, $a ) {
            install_file( $path, $path =~ s{^debian/tmp}{$tmpdir}r );
        }

        # Strip unreproducible build flags from *.ali and *.gpr.
        # May be removed when BUILD_PATH_PREFIX_MAP is accepted in gcc.
        # Restore read-only mode 444 lost by install_file.
        my @dest_ali_files = map { s{^debian/tmp}{$tmpdir}r } @ali_files;
        doit( 'sed', '-i', 's@' . $cwd . '@/build@g',
            @dest_ali_files, $gpr =~ s{^debian/tmp}{$tmpdir}r );
        reset_perm_and_owner( oct('444'), @dest_ali_files );

        # Recreate the development symbolic link (see the comments
        # about the lib package sub below).
        my $shared = basename( readlink $so );
        make_symlink( "$deb_lib_dir/lib$name.so", "$deb_lib_dir/$shared",
            $tmpdir );

        # Display present and ignored files.
        for my $path ( $gprtrash, $la ) {
            if ( -e $path ) {
                verbose_print("Not installing $path");
            }
        }

        addsubstvar(
            $dev_pkg{$name}, 'ada:Depends',
            $lib_pkg{$name}, '= $' . '{binary:Version}'
        );

        my $gnat_with_hash = "gnat-$deb_gnat_version";
        if ( $deb_gnat_version ne '13' ) {
            $gnat_with_hash .=
              q{-} . dpkg_architecture_value('DEB_HOST_GNU_TYPE') =~ tr/_/-/r;
        }
        addsubstvar( $dev_pkg{$name}, 'ada:Depends',
            provided( $gnat_with_hash, "gnat-$deb_gnat_version" ),
        );

        # The 'gnat' empty package depends on gnat-$deb_gnat_version.
        # Hardcode version restrictions and the indirect dependency in
        # order to help the resolvers in experimental when a GCC
        # transition is prepared.
        addsubstvar( $dev_pkg{$name}, 'ada:Depends',
            "gnat-$deb_gnat_version" );
        addsubstvar( $dev_pkg{$name}, 'ada:Depends',
            'gnat', ">= $deb_gnat_version" );
        addsubstvar( $dev_pkg{$name}, 'ada:Depends',
            'gnat', '<< ' . ( $deb_gnat_version + 1 ) );

        addsubstvar( $dev_pkg{$name}, 'ada:Provides',
            $dev_pkg{$name} . q{-} . checksum(@ali_files) );

        # List packages imported by the project (assuming a single
        # line per import).
        open my $fh, q{<}, $gpr;
        while (<$fh>) {
            if (m/ ^ with [ ]+ " (\w+) (?: [.]gpr )? " ; $ /) {
                add_import_to_ada_depends( $name, $1 );
            }
        }
        close $fh;
    }
    return;
}

sub process_lib_package : prototype($) ($name) {

    # Development symbolic link (in the -dev package)
    my $so = "debian/tmp/$deb_lib_dir/lib$name.so";

    # The concrete file containing the shared library.
    my $lib;

    # The ldconfig symbolic link, when $lib differs from the SO name.
    my $ldcfg;

    if ( -l $so ) {
        $lib = basename( readlink $so );
        if ( -l "debian/tmp/$deb_lib_dir/$lib" ) {

            # libNAME.so -> SONAME -> LIB
            # Cmake installs this structure.
            $ldcfg = $lib;
            $lib   = readlink "debian/tmp/$deb_lib_dir/$ldcfg";
            if ( not -f "debian/tmp/$deb_lib_dir/$lib" ) {
                error("lib$name.so -> $ldcfg -> $lib is not a file");
            }
            if ( $ldcfg ne ( my $soname = extract_shared_object_name($lib) ) ) {
                error("lib$name.so -> $ldcfg -> $lib instead of $soname");
            }
        }
        elsif ( $lib ne ( my $soname = extract_shared_object_name($lib) ) ) {

            # libNAME.so -> LIB (= SONAME)
            # Eg gprinstall, with ../DEV_HOST_MULTIARCH/ redundant path
            # components in the symbolic link.
            $ldcfg = $soname;
            if ( not -l "debian/tmp/$deb_lib_dir/$ldcfg" ) {
                error("lib$name.so -> $lib, but no $soname ldconfig link");
            }
            if ( $lib ne ( my $tgt = readlink "debian/tmp/$deb_lib_dir/$ldcfg" )
              )
            {
                error("lib$name.so -> $lib, but $ldcfg -> $tgt");
            }
        }
        else {

            # libNAME.so and SONAME both -> LIB
            # Libtool installs this structure.
            # $ldcfg remains undefined.
        }
    }

    log_installed_files(
        $lib_pkg{$name},
        defined $lib   ? "debian/tmp/$deb_lib_dir/$lib"   : (),
        defined $ldcfg ? "debian/tmp/$deb_lib_dir/$ldcfg" : (),
    );
    if ( process_pkg( $lib_pkg{$name} ) ) {
        my $tmpdir = tmpdir( $lib_pkg{$name} );

        install_dir("$tmpdir/$deb_lib_dir");

        defined $lib or error("$so symlink is missing");
        install_lib( "debian/tmp/$deb_lib_dir/$lib",
            "$tmpdir/$deb_lib_dir/$lib" );

        if ( defined $ldcfg ) {
            make_symlink( "$deb_lib_dir/$ldcfg", "$deb_lib_dir/$lib", $tmpdir );
        }
    }
    return;
}

# ----------------------------------------------------------------------
# Actually do something.

# Alert users of previous versions of this tool.
if ( -e 'debian/ada_libraries' ) {
    error('debian/ada_libraries is deprecated');
}
if (@ARGV) {
    error('non option command line arguments are deprecated');
}

if ( $dh{EXPORT_VERSIONS} ) {

    # Invoked by /usr/share/ada/packaging.mk.
    # Just export data in Make format for debian/rules.
    export_versions;
}
else {

    # Invoked by dh-sequence-ada-library after dh_auto_install.
    # Dispatch from debian/tmp to package directories.
    # See /usr/share/doc/debhelper/PROGRAMMING.gz.
    on_items_in_parallel(
        [ keys %dev_pkg ],
        sub {
            for my $name (@_) {
                process_dev_package_and_not_installed($name);
                process_lib_package($name);
            }
        }
    );
}