#!/usr/bin/perl

use v5.36; # say + strict + warnings + v5.36 bundle
use Config::Properties;
use Debian::Debhelper::Buildsystem::R qw(parse_depends);
use Dpkg::Index;
use Dpkg::Control;
use Dpkg::Deps;
use Dpkg::Version qw(version_normalize_relation version_compare_relation);
use Getopt::Long;
use Pod::Usage;
use List::Util qw(any first uniq);
use File::Path qw(make_path);

my $opt_desc = 0;
my $opt_help = 0;

GetOptions('help|?' => \$opt_help, 'desc|d' => \$opt_desc);
pod2usage(1) if $opt_help;

( -d "debian") or die "No debian/ directory, this tool updates existing R packaging";
( -e "DESCRIPTION") or die "No DESCRIPTION file, is this an R package?";

## Load control files

my $desc = Dpkg::Control->new(type => Dpkg::Control::CTRL_UNKNOWN);
$desc->load("DESCRIPTION");
$desc->{Depends} //= "" ;
$desc->{Imports} //= "" ;
$desc->{LinkingTo} //= "";
$desc->{Suggests} //= "";
$desc->{SystemRequirements} //= "";

my $dctrl = Dpkg::Control::Info->new();
$dctrl->load("debian/control");
my $dsrc = $dctrl->get_source();
my $dbin = $dctrl->get_pkg_by_idx(1);

my $dtest;
my $tctrl = 'debian/tests/control';
if ( -e $tctrl ) {
    $dtest = Dpkg::Control->new(type => CTRL_TESTS);
    $dtest->load($tctrl);
}

## Load Debian archive data

my @aptavail = qx/grep-aptavail -P -s Package -n -e ^r-/;
my %apthash;
@apthash{@aptavail} = ();

## Use oldoldstable information if available

my %oldold_vers;
my $oldold_Sources = '/var/lib/apt/lists/deb.debian.org_debian_dists_oldoldstable_main_source_Sources';
if ( -e $oldold_Sources ) {
    my $oldold_idx = Dpkg::Index->new(type => CTRL_INDEX_SRC);
       $oldold_idx ->load('/var/lib/apt/lists/deb.debian.org_debian_dists_oldoldstable_main_source_Sources');

    for my $s ($oldold_idx->get()) {
        my $v = $s->{Version} // next;
        my $b = $s->{Binary}  // next;
        for my $pkg (map { s/^\s+|\s+$//gr } split /,/, $b) {
            $oldold_vers{$pkg} = $v;
        }
    }
} else { say "W: You need to add oldoldstable deb-src apt entry to remove unneeded version dependencies" }

sub parse_pkg_versiondep {
    my $d = shift;
    my ($p) = $d =~ /^\s*([A-Za-z0-9][A-Za-z0-9+.-]*)/;
    my ($v) = $d =~ /\(\s*([^)]*?)\s*\)/;
    ($p, $v);
}

sub check_oldold_dep {
    my $d = shift;
    my ($p, $v) = parse_pkg_versiondep($d);
    return $d unless $v;
    return $d unless $oldold_vers{$p};
    if ( $v =~ />=\s*(\S+)/ ) {
        return $p if version_compare_relation($oldold_vers{$p}, '>=', $1);
    }
    return $d;
}

sub oldold_baseline {
    my @deps = grep { defined && length } @_;
    map { check_oldold_dep($_) } @deps;
}

# Store all Suggested R packages that are mentioned in DESCRIPTION but without version to be able to compare with Test-Depends
my @raw_suggests;

sub deps_concat_cme {
    # Match the wrap-and-sort -ast style that libconfig-model-dpkg-perl uses since version 3.015
    return "\n" . join (",\n" , oldold_baseline(grep {defined && length} uniq @_)) . ","
}

my $tctrldata;

my $nullfacts = Dpkg::Deps::KnownFacts->new;
sub deduplicate_deps {
    my @deps = grep { defined && length } @_;
    return @_ unless @deps;
    my $d = deps_parse( deps_concat(@deps) ); # array to deps object
    $d->simplify_deps($nullfacts);
    map { $_->output } $d->get_deps;          # deps object to array
}

sub unmanaged {
    my $rawtext = shift;
    chomp $rawtext;
    $rawtext =~ s/^\s+//; # Starts with a leading newline since libconfig-model-dpkg-perl follows the wrap-and-sort -ast style
    my @deps = split(/\s*,\s*/m, $rawtext);
    my @keep;
    foreach my $d (@deps) {
        if ( any { $_ eq $d } @raw_suggests ) {
            say "I: $d is in suggests and can be ignored";
	} elsif ( $d =~ /\$\{[^}]+\}/) {
            # Silently discard DPKG substvars; they will be re-added later
	} elsif ( $d =~ /r-base-dev/ ) {
            # r-base-dev is used in packages like r-cran-rcppparallel but not specified in DESCRIPTION
            # Thus it needs to be kept in the unmanaged list.
            # This has the consequence that all following r-* packages are kept as well - so place this at the end of d/t/control
            push @keep, $d;
        } elsif ($d !~ /^(r-|debhelper(?:-compat)?|dh-r|\$)/) {
            say "I: keeping unmanaged dependency: $d";
            push @keep, $d;
        } elsif ( @keep && $d =~ /^r-/ ) {
            say "I: keep also $d since it is specified behind other unmanaged depencency";
            push @keep, $d;
        } elsif ( $d !~ '^@' ) {
            say "I: $d is no R package and needed for other purposes";
            push @keep, $d;
        }
    }
    return @keep;
}

say "I: Updating Build-Depends";

my @unmanaged_builddeps = unmanaged($dsrc->{'Build-Depends'});
my @rdepends = parse_depends("Depends", $desc->{Depends}, \%apthash);
my @rimports = parse_depends("Imports", $desc->{Imports}, \%apthash);
my @rlinkingto = parse_depends("LinkingTo", $desc->{LinkingTo}, \%apthash);
my @rsuggests = parse_depends("Suggests", $desc->{Suggests}, \%apthash);
@raw_suggests = map { s/ *\(.*\) *//r } @rsuggests;
my @rsystemrequirements;
if ( $desc->{SystemRequirements} =~ /^gsl$/ ) {
  @rsystemrequirements = ('libgsl-dev');
}

say "I: Check for documentation dependencies";

my @docrequirements;
push @docrequirements, ('r-cran-knitr', 'r-cran-markdown') if (system("grep -q 'markdownToHTML' debian/rules") == 0);
push @docrequirements, ('r-bioc-biocstyle') if ( @docrequirements && (`grep -q 'BiocStyle' inst/doc/* ; echo \$?` == 0) );

my $compiled = 0;
if ( $desc->{NeedsCompilation} ) {
  $compiled = lc $desc->{NeedsCompilation} eq "yes";
} else {
  say "W: NeedsCompilation field is missing in DESCRIPTION" ;
  # some DESCRIPTION files (for instance r-cran-deal) are lacking NeedsCompilation field
  # try to find other means for the decision whether compilation is needed
  # for the moment simply check whether src/ dir exists
  if (-e 'src' and -d 'src') {
    say "W: Directory src exists despite NeedsCompilation field is missing in DESCRIPTION" ;
    my @files = glob("src/*.[cf]");
    if ( @files ) {
      $compiled = 1;
      say "I: Set Architecture=any since there are *.c or *.f files." ;
    }
  }
}

my $is_bioc = $dsrc->{Source} =~ /^r-bioc-/;

# Throw error if debian/tests/autopkgtest-pkg-r.conf does not exist but some debian/tests/control* can be found
# This is a sign that the r-bioc-* package was not migrated yet.  However, it also can be that the test should be deactivated for good reasons (renamed d/control)
if ( $is_bioc && ! -e 'debian/tests/autopkgtest-pkg-r.conf' && -e 'debian/tests/control' ) {
    # Throw an error at end and ask for manual inspection to remove debian/tests/control
    die "E: debian/tests/control was found in BioConductor package.  Please remove this manually."
}

my $is_extra_depends = 0;   # We are parsing the field extra_depends/Depends which is continued in several lines
if ( ! $is_bioc ) {
    if ( ! -e $tctrl & ! exists $dsrc->{Testsuite} ) {
        say "W: No $tctrl and no Testsuite field, adding Testsuite: autopkgtest-pkg-r";
        $dsrc->{Testsuite} = "autopkgtest-pkg-r";
        $tctrldata->{'Tests'} = 'run-unit-test';
        $tctrldata->{'Restrictions'} = 'allow-stderr';
    } else {
        if ( $dtest ) {
            for my $field (qw(Architecture Features Restrictions Tests Test-Command)) {
                $tctrldata->{$field} = $dtest->{$field} if defined ($dtest->{$field});
            }
            if ( $dtest->{'Depends'} ) {
                push @rsuggests, unmanaged($dtest->{'Depends'});
            }
        }
    }
} else {
    $tctrl = 'debian/tests/autopkgtest-pkg-r.conf';
    if ( ! -e $tctrl ) {
        if ( ! exists $dsrc->{Testsuite} ) {
            say "W: No $tctrl and no Testsuite field, adding Testsuite: autopkgtest-pkg-r";
            $dsrc->{Testsuite} = "autopkgtest-pkg-r";
        } else {
            say "W: $tctrl not found, trying to write new one.";
        }
    } else {
	my $p = Config::Properties->new();
	my $fh = IO::File->new("debian/tests/autopkgtest-pkg-r.conf", "r");
	$p->load($fh);
        for my $field (qw(architecture extra_restrictions)) {
            $tctrldata->{$field} = $p->getProperty($field);
        }
        push @rsuggests, unmanaged($p->getProperty("extra_depends"));
    }
}

my $debhelper_compat = first { /^debhelper-compat/ } @unmanaged_builddeps;
say "I: Using debhelper compat from build-depends: $debhelper_compat";

my $dhrversion = "";
if ( $dsrc->{'Build-Depends'} =~ m{
        (?:^|,) \s*     # start of string or comma, optional spaces
        dh-r \s*        # the package and optional spaces
        (               # capture group 1: the whole (...) block
        \(  [^)]*  \)   # opening parenthesis, anything except ')', then closing parenthesis
        )
        \s* (?:,|$)     # optional spaces, and comma or end of string
    }x ) {
    my $dhrversion = $1;
    say "I: Keep versioned Build-Depends: dh-r $dhrversion";
}

$dsrc->{'Build-Depends'} = deps_concat_cme(deduplicate_deps($debhelper_compat, "dh-r $dhrversion", "r-base-dev", @rdepends, @rimports, @rlinkingto, @unmanaged_builddeps, @rsystemrequirements, @docrequirements));
if ( $dsrc->{'Maintainer'} =~ ".*\@lists.alioth.debian.org>\$" ) {
  $dsrc->{'Maintainer'} = "Debian R Packages Maintainers <r-pkg-team\@alioth-lists.debian.net>" ;
}
if ( $dsrc->{'Maintainer'} =~ ".*lists.*\.debian\..*" ) {
  $dsrc->{'Vcs-Browser'} = "https://salsa.debian.org/r-pkg-team/".$dsrc->{'Source'};
  $dsrc->{'Vcs-Git'} = $dsrc->{'Vcs-Browser'}.".git";
}

if ( ! $is_bioc ) {
    # set $tctrldata->{'Depends'} only if @rsuggests is not empty
    if ( @rsuggests ) {
        $tctrldata->{'Depends'} = deps_concat_cme("@", @rsuggests);
    }
}

# Write debian/tests/ files when we need
my $output_control = 0;
my $fhtctrl;
if ( ! $is_bioc || @rsuggests ) {
    # check for r-cran- packages whether something needs to be written
    foreach my $key ('Tests', 'Depends', 'Restrictions', 'Features', 'Architecture', 'Test-Command') {
        if ( $tctrldata->{$key} ) {
            $output_control = 1;
        }
    }
    if ( ! $is_bioc ) {
        if ( ! -d 'tests' ) { # Seems upstream does not ship any test
            say "W: Upstream does not provide a tests dir thus not creating $tctrl";
            $output_control = 0;
            # even if upstream has defined Suggests this does not help if tests are not specified
            @rsuggests = () ;
        }
    }
    if ( $output_control || @rsuggests ) {
        if ( ! -d 'debian/tests' ) {
            make_path('debian/tests') || die "Failed to create directory debian/tests";
        }
        my $tests_ctrl = Dpkg::Control->new(type => Dpkg::Control::CTRL_TESTS);
        for my $fld (qw(Tests Test-Command Depends Restrictions Features Architecture)) {
            $tests_ctrl->{$fld} = $tctrldata->{$fld} if $tctrldata->{$fld};
        }
        open( $fhtctrl, ">", $tctrl) or die "Unable to open $tctrl";
        $tests_ctrl->output($fhtctrl);
        close($fhtctrl);
    } else {
        if ( -d 'tests' && ! $is_bioc ) {
            say "W: No tests control written despite this package is featuning a tests directory";
        }
    }
}
if ( $is_bioc ) {
    # override debian/tests/autopkgtest-pkg-r.conf
    if ( @rsuggests ) {
        open( $fhtctrl, ">", $tctrl) or die "Unable to open $tctrl";
        say $fhtctrl "extra_depends=" . join (", \\\n              ", @rsuggests);
        foreach my $key ('extra_restrictions', 'architecture') {
            if ( $tctrldata->{$key} ) {
                say $fhtctrl "$key=$tctrldata->{$key}";
            }
        }
    } else {
        say "I: No Suggests specified in DESCRIPTION thus not writing $tctrl" ;
    }
}
if ( $output_control || @rsuggests ) {
    close($fhtctrl);
}

say "I: Updating binary Depends, Recommends, Suggests";
my @unmanaged_depends = unmanaged($dbin->{Depends});
my @unmanaged_recommends = unmanaged($dbin->{Recommends});
my @unmanaged_suggests = unmanaged($dbin->{Suggests});

$dbin->{Depends} = deps_concat_cme("\${R:Depends}", $compiled ? "\${shlibs:Depends}" : "", "\${misc:Depends}", @unmanaged_depends);
$dbin->{Recommends} = deps_concat_cme("\${R:Recommends}", @unmanaged_recommends);
$dbin->{Suggests} = deps_concat_cme("\${R:Suggests}", @unmanaged_suggests);

if ( ! -e 'debian/tests/control' & ! exists $dsrc->{Testsuite} ) {
    say "W: No debian/tests/control and no Testsuite field, adding Testsuite: autopkgtest-pkg-r";
    $dsrc->{Testsuite} = "autopkgtest-pkg-r";
}

if ($opt_desc) {
    say "I: Updating package description";
    my $longdesc = $desc->{Description};
    $longdesc =~ s/^\s*//gm;
    $dbin->{Description} = "$desc->{Title}\n$longdesc";
}

open(my $fh, ">", "debian/control") or die "Can't write to debian/control";
# Set same field order as in cme to minimse diffs
$dsrc->set_output_order(qw(
    Source
    Standards-Version
    Maintainer
    Uploaders
    Section
    Testsuite
    Build-Depends
    Vcs-Browser
    Vcs-Git
    Homepage
    Rules-Requires-Root
));
$dctrl->output($fh);
close($fh);

__END__

=head1 NAME

dh-update-R - Updates d/control for a debian R package

=head1 SYNOPSIS

dh-update-R [options]

 Options:
    --help
    --desc Update the package description

=head1 OPTIONS

=over 8

=item B<--help>

Print this help message.

=back

=head1 DESCRIPTION

B<dh-update-R> should be run from the root of an unpacked R tarball (ie, the
directory containing DESCRIPTION), where there is already a debian/ directory.
This tools attempts to update files in debian/ after a new upstream version has
been imported.
