#!/usr/bin/perl
# dh_builtusing - set dpkg-gencontrol substitution variables for the Built-Using field
# SPDX-License-Identifier: GPL-3.0+
# (GNU General Public License, version 3 or later at your convenience)
# Copyright 2023-2026 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 feature qw(signatures);
use re '/amsx';
use strict;
use warnings;

use Debian::Debhelper::Dh_Lib;
use Dpkg::BuildProfiles 'get_build_profiles';
use Dpkg::Control::Info;
use Dpkg::Deps;
use English '-no_match_vars';
use Memoize;

my $control_file     = 'debian/control';
my $logorrheic_print = sub { };
init(
    options => {
        'c=s' => sub {
            warning '-c option is deprecated';
            $control_file = $_[1];
        },
        'logorrheic' => sub {
            $dh{VERBOSE} = 1;
            $logorrheic_print = \&verbose_print;
        },
    }
);
my $control = Dpkg::Control::Info->new($control_file);

# pkg: a binary package that may
#   be produced by the current build,
#   use a dh_builtusing substitution variable.
# dep: a binary package that may
#   match a dh_builtusing substitution variable,
#   be installed during the build,
#   belong to a Build-Depends field,
# Variables disabled by restrictions are processed immediately.
# Normal expansions are stored as [pkg, var, dep, first] in a todo list
# so that dpkg-query runs at most once.
# Then a second pass actually sets the variables.
# $first is true when $dep was the first option in an alternative in
# Build-Depends.  This triggers a warning when it is not installed.
my @todo;

# Deps in the Build-Depends$suffix control field, filtered by the
# architecture and profile restrictions.
# The result of deps_parse is an instance of AND or Simple.
# AND items are instances of OR or Simple.
# OR  items are instances of Simple.
# This function returns an array of OR or Simple.
sub build_depends : prototype($) ($suffix) {
    my $contents = $control->get_source->{"Build-Depends$suffix"};
    $contents or return ();
    return deps_parse(
        $contents,
        reduce_restrictions => 1,
        build_profiles      => [get_build_profiles],
        build_dep           => 1,
    )->get_deps;
}
memoize('build_depends');

# A hash mapping an installed dep to a "SOURCE (= VERSION)" relation.
sub source_version : prototype(@) (@binaries) {
    my $format =
"\${db:Status-Abbrev}\${Package}:\${source:Package} (= \${source:Version})\n";
    my @cmd = ( 'dpkg-query', '-Wf', $format, @binaries );
    my @out = qx_cmd(@cmd);                                  # _;
    $logorrheic_print->("      source_version: @cmd -> @out");
    my %result;
    for (@out) {
        chomp;
        if (m/ ^ .i. ([^:]*) : (.*) /) {
            if ( exists $result{$1} and $result{$1} ne $2 ) {
                die "$1: distinct versions co-installed?\n";
            }
            $logorrheic_print->("  $1: $2");
            $result{$1} = $2;
        }
    }
    return \%result;
}

sub search_installed_packages : prototype($$$) ( $pkg, $var, $glob ) {
    $glob =~ y/DPS/.+*/;
    my $format = "\${db:Status-Abbrev}\${Package}\n";
    my @cmd    = ( 'dpkg-query', '-Wf', $format, $glob );
    my @out    = qx_cmd(@cmd);                              # _;
    $logorrheic_print->("      search_installed_packages: @cmd -> @out");
    for (@out) {
        chomp;
        s/ ^ .i. // or next;
        push @todo, [ $pkg, $var, $_, 1 ];
        warning "$var: please add $_ to Build-Depends.";
    }
    return;
}

my $RE_PATTERN = qr/       [[:lower:]\dS] [[:lower:]\dDPS-] +     /;
my $RE_ARCH    = qr/     : [[:lower:]]    [[:lower:]\d]     +     /;
my $RE_CAPTURE = qr{
   [$][{]
  ( dh- (?:static)? builtusing:         # var
    ( $RE_PATTERN ) ( $RE_ARCH )?
  )
  [}]
  ( [^,|]* )                            # restrictions
};

sub search_in_dependency_string : prototype($$) ( $pkg, $string ) {
    $logorrheic_print->("  dependency_string=|$string|");
    while ( $string =~ m/$RE_CAPTURE/g ) {
        my ( $var, $pattern, $arch, $restrictions ) = ( $1, $2, $3, $4 );
        if ($arch) {
            warning "$var: architecture qualifiers are deprecated";
        }
        $logorrheic_print->("    v=$var p=$pattern r=|$restrictions|");
        my $parsed = Dpkg::Deps::Simple->new("fake $restrictions");
        if ( $parsed->{relation} ) {
            error("$var carries a version relation");
        }

        if (    $parsed->arch_is_concerned(hostarch)
            and $parsed->profile_is_concerned( [get_build_profiles] ) )
        {
            my $regex = $pattern;
            $regex =~ s/ D /[.]/g;
            $regex =~ s/ P /[+]/g;
            $regex =~ s/ S /.*/g;
            my $suffix   = package_is_arch_all($pkg) ? '-Indep' : '-Arch';
            my $old_todo = @todo;
            for ( build_depends q{}, build_depends $suffix ) {    # OR / Simple
                my $first = 1;            # first option?
                for ( $_->get_deps ) {    # Simple
                    if ( $_->{package} =~ m/^$regex$/ ) {
                        push @todo, [ $pkg, $var, $_->{package}, $first ];
                    }
                    $first = 0;
                }
            }

            # If no build dependency matches, search installed packages.
            if ( $old_todo eq @todo ) {
                search_installed_packages( $pkg, $var, $pattern );
            }
            if ( $old_todo eq @todo ) {
                error "$var: no match in (active) Build-Depends (or $suffix).";
            }
        }
        else {
            verbose_print(
                "In package $pkg, substvar $var += disabled-by-restriction");
            addsubstvar( $pkg, $var, 'disabled-by-restriction (= 0)' );
        }
    }
    return;
}

# Only search in uncommented right hand sides.
sub search_in_substvars_file : prototype($) ($pkg) {
    my $path = 'debian/' . pkgext($pkg) . 'substvars';
    if ( -e $path ) {
        $logorrheic_print->("substvars_file=$path");
        my $old_todo = @todo;
        open my $file, q{<}, $path or error("open $path failed: $ERRNO");
        while (<$file>) {
            if (m/ ^ [[:alnum:]] [[:alnum:]:-]* [?]? = (.*) /) {
                search_in_dependency_string( $pkg, $1 );
            }
        }
        close $file or error("close $path failed: $ERRNO");
        if ( $old_todo ne @todo ) {
            warning("dh-builtusing variables in $path are deprecated.");
        }
    }
    return;
}

for my $pkg ( @{ $dh{DOPACKAGES} } ) {

    # Parse the substvars file before extending it.
    search_in_substvars_file($pkg);
    for my $field_name ( 'Built-Using', 'Static-Built-Using' ) {
        $logorrheic_print->("pkg=$pkg field=$field_name");
        my $field_contents = $control->get_pkg_by_name($pkg)->{$field_name};
        if ($field_contents) {
            search_in_dependency_string( $pkg, $field_contents );
        }
    }
}
if (@todo) {
    my $relations = source_version( map { ${$_}[2] } @todo );
    for (@todo) {
        my ( $pkg, $var, $dep, $first ) = @{$_};
        if ( exists $relations->{$dep} ) {
            $logorrheic_print->("$pkg.$var += $relations->{$dep}");
            addsubstvar $pkg, $var, $relations->{$dep};
        }
        elsif ($first) {
            warning "$var: $dep is not installed";
        }
        else {
            $logorrheic_print->("$var: $dep is not installed");
        }
    }
}
