#!/usr/bin/perl

use feature say;
use strict;
use Debian::Debhelper::Buildsystem::R qw(parse_deps);
use Dpkg::Control;
use Dpkg::Deps qw(deps_parse);
use Getopt::Long;
use Pod::Usage;
use List::Util qw(first);
use File::Glob ':glob';
use File::Path qw(make_path);
use experimental qw(smartmatch); #https://www.nerdsheaven.de/magazin/perl-warning-smartmatch-is-experimental/

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?";

my $desc = Dpkg::Control->new(type => Dpkg::Control::CTRL_UNKNOWN);
$desc->load("DESCRIPTION");

my $dctrl = Dpkg::Control::Info->new();
$dctrl->load("debian/control");

my $dsrc = $dctrl->get_source();
my $dbin = $dctrl->get_pkg_by_idx(1);

my @aptavail = qx/grep-aptavail -P -s Package -n -e ^r-/;
my %apthash;
@apthash{@aptavail} = ();
my @global_dep_list = ();
# This global list contains all those Test-Depends that are maintained manually.
# The packages are detected once a non-R package is specified as Test-Depends
# All following packages (no matter whether R packages or not (except if found
# in Suggests field of DESCRIPTION file) will be considered manually maintained
my @tdep_manual_list = ();
 # 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 {
    # Dpkg::Deps::deps_concat generates "dep, , , " if some arguments are empty strings
    my $field = @_[0];
    shift @_ ;
    my (@dep_list) = @_;
    @dep_list = grep { /[a-z]/ } @dep_list;
    my $dep ;
    my @dedup_dep_list = () ;
    foreach (@dep_list) {
      $dep = $_ ;
      s/ .*// ;
      unless ($_ ~~ @global_dep_list ) {
        push @global_dep_list, $_ ;
        push @dedup_dep_list, $dep ;
      } else {
        say "Ignore duplicated dependency $dep" ;
      }
    }
    my $empty = substr('                              ', 0, length($field)+1);
    return join ",\n$empty", @dedup_dep_list;
}

my $tctrl;
my $key;
my $tctrldata;
my $control_found_where_autopkgtest_pkg_r_conf_is_expected = 0;

sub tdeps_gen_list {
    my ($lvalue, $has_manual_depends) = @_; 
    chomp $lvalue ;
    foreach (split(/\s*,\s*/m, $lvalue)) {
        my $tdep = $_;
        s/[\s]*\([\s>=\d.~+dfsg-]+\)\s*//;
        if ( $_ ~~ @raw_suggests ) {
            say "I: $_ is in suggests and can be ignored";
        } elsif ( exists $apthash{"$_\n"} ) {
            if ( $_ =~ /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 and this is realised by setting $has_manual_depends true
                 # This has the consequence that all following r-* packages are kept as well - so place this at the end of d/t/control
                 $has_manual_depends = 1;
            }
            say "I: $_ is a known R package, however, if the manual list has startet it is assumed that it was added manually" ;
            if ( $has_manual_depends ) {
                 push @tdep_manual_list, $tdep;
            }
        } else {
            if ( $tdep !~ '^@' ) {
                say "I: $_ is no R package and needed for other purposes";
                push @tdep_manual_list, $tdep;
                $has_manual_depends = 1;
            }
        }
    }
    return $has_manual_depends;
}


my $dhrversion = "";

sub unmanaged {
    my $field = @_[0];
    shift @_;
    my $rawtext = shift;
    # deps_parse errors on substvars like ${R:Depends}, so split it manually
    my @deps = split(/\s*,\s*/m, $rawtext);
    my @keep;
    foreach my $d (@deps) {
        if ($d !~ /^(r-|debhelper(?:-compat)?|dh-r|\$)/) {
            say "I: keeping unmanaged dependency: $d";
            push(@keep, $d);
        } else {
            if ( @keep && $d =~ /^r-/ ) {
              say "I: keep also $d since it is specified behind other unmanaged depencency";
              push(@keep, $d);
            }
        }
        if ($d =~ /^dh-r\s+\(\s*>=\s*\d+\s*\)\s*$/ ) {
            $d =~ s/^dh-r\s+/ / ;
            $dhrversion = $d;
            say "I: Keep versioned Build-Depends: dh-r$dhrversion";
        }
    }
    return deps_concat($field, @keep);
}

say "I: Updating Build-Depends";

my $unmanaged_builddeps = unmanaged("Build-Depends", $dsrc->{'Build-Depends'});
if ( ! $desc->{Depends} ) { $desc->{Depends} = ""; }
if ( ! $desc->{Imports} ) { $desc->{Imports} = ""; }
if ( ! $desc->{LinkingTo} ) { $desc->{LinkingTo} = ""; }
if ( ! $desc->{SystemRequirements} ) { $desc->{SystemRequirements} = ""; }
my $rdepends = deps_concat("Build-Depends", Debian::Debhelper::Buildsystem::R::parse_depends("Depends", $desc->{Depends}, \%apthash));
my $rimports = deps_concat("Build-Depends", Debian::Debhelper::Buildsystem::R::parse_depends("Imports", $desc->{Imports}, \%apthash));
my $rlinkingto = deps_concat("Build-Depends", Debian::Debhelper::Buildsystem::R::parse_depends("LinkingTo", $desc->{LinkingTo}, \%apthash));
my $rsystemrequirements = "";
if ( $desc->{SystemRequirements} =~ /^gsl$/ ) {
  $rsystemrequirements = deps_concat("Build-Depends", 'libgsl-dev');
}
my $docrequirements = "";
open(my $fhr, '<', 'debian/rules') or die "Error opening: $!";
while (my $rline = <$fhr>) {
  my @requires = $rline =~ /require\(([^)]+)\)/g;
  my @keepdoc;
  if (@requires) {
    foreach (@requires) {
      push(@keepdoc, 'r-cran-'.$_);
    }
  }
  if (@keepdoc) {
    if ( `grep -q 'BiocStyle' inst/doc/* ; echo \$?` == 0 ) {
      # if the doc might use BiocStyle we need this dependency as well
      # Note: This also leads to r-bioc-biocstyle in Test-Depends,
      #       but this should not cause any harm
      push(@keepdoc, 'r-bioc-biocstyle');
    }
    $docrequirements = deps_concat("Build-Depends",@keepdoc);
  }
}
close($fhr);
my $compiled = "no";
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 = "yes";
      say "I: Set Architecture=any since there are *.c or *.f files." ;
    }
  }
}

if ( ! $desc->{Suggests} ) { $desc->{Suggests} = ""; }
my $rsuggests ;
if ( $dsrc->{Source} =~ /^r-bioc-/ ) {
    $rsuggests = deps_concat("extra_depends", Debian::Debhelper::Buildsystem::R::parse_depends("Suggests", $desc->{Suggests}, \%apthash));
} else {
    $rsuggests = deps_concat("Depends", Debian::Debhelper::Buildsystem::R::parse_depends("Suggests", $desc->{Suggests}, \%apthash));
}

foreach (split(/\s*,\s*/m, $rsuggests)) {
    s/ *\(.*\) *//;
    push @raw_suggests, $_;
}

my $is_extra_depends = 0;   # We are parsing the field extra_depends/Depends which is continued in several lines
my $has_manual_depends = 0; # There are manual Test-Depends specified which are non-R packages.
if ( ! $tctrldata->{extra_depends} ) { $tctrldata->{extra_depends} = ""; }
if ( $dsrc->{Source} !~ /^r-bioc-/) {
    $tctrl = 'debian/tests/control';
    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 ( -e $tctrl ) {
            open(my $fh, '<', $tctrl) or die "Fehler beim Öffnen der Datei: $!";

            while (my $line = <$fh>) {
                chomp $line;
                $line =~ s/#.*// ;
                my $value;
                if ( $line =~ /^([^:]+):\s*(.*)$/ ) {
                    if ( $1 ~~ ['Architecture', 'Features', 'Restrictions', 'Tests', 'Test-Command'] ) {
                        $key = $1;
                        $value = $2;
                        $tctrldata->{$key} = $value;
                        $is_extra_depends = 0;
                    } elsif ( $1 == 'Depends' ) {
                        $is_extra_depends = 1;
                        $value = $2;
                    } else {
                        $is_extra_depends = 0;
                    }
                }
                if ( $is_extra_depends ) {
                    if ( ! $value ) {
                        ($value) = $line =~ /^[\s]+(.+)[\s]*$/ ;
                    }
                    $has_manual_depends = tdeps_gen_list($value, $has_manual_depends);
                }
            }
            close($fh);
        }
    }
} else {
    $tctrl = 'debian/tests/autopkgtest-pkg-r.conf';
    # 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 ( ! -e $tctrl ) {
        my @control_exists = bsd_glob('debian/tests/*control*');

        if (@control_exists) {
            # Check whether the file is really debian/tests/control which should be removed
            if ( -e 'debian/tests/control' ) {
                 # Throw an error at end and ask for manual inspection to remove
                 # debian/tests/control
                 $control_found_where_autopkgtest_pkg_r_conf_is_expected = 1;
            }
        }
    }
    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 {
        open(my $fh, '<', $tctrl) or die "Error opening file: $!";

        $is_extra_depends = 0;
        while (my $line = <$fh>) {
            chomp $line;
            $line =~ s/#.*// ;
            my $value;
            if ($line =~ /^([^=]+)=\s*(.*)$/) {
                my $lkey = $1;
                my $lvalue = $2;
                if ( $lkey ~~ ['architecture', 'extra_restrictions'] ) {
                    $tctrldata->{$lkey} = $lvalue;
                }
                elsif ( $lkey =~ 'extra_depends' ) {
                    # Check whether line ends with '\' to be continued
                    if ( $lvalue =~ /^[\s]*(.+)\s*\\/ ) {
                        # Line will be continued
                        $is_extra_depends = 1;
                        $lvalue = $1;
                    }
                    $has_manual_depends = tdeps_gen_list($lvalue, $has_manual_depends);
                }
            }
            elsif ( $is_extra_depends ) {
                $line =~ s/^\s+|\s+$//g;
                if ( $line =~ /^([^\s]+)\s*\\/ ) {
                    $has_manual_depends = tdeps_gen_list($1, $has_manual_depends);
                    if ( $1 =~ /^(.+),/ ) {
                        $is_extra_depends = 1;
                    }
                } else {
                    $value = $line;
                }
            }
            elsif ( $is_extra_depends ) {
                $line =~ s/^\s+|\s+$//g;
                if ( $line =~ /^([^\s]+)\s*\\/ ) {
                    $has_manual_depends = tdeps_gen_list($1, $has_manual_depends);
                    if ( $1 =~ /^(.+),/ ) {
                        $is_extra_depends = 1;
                    }
                } else {
                    $value = $line;
                }
            }
            if ( exists $apthash{"$value\n"}) {
                # $value is a known R package, however, if the manual list has startet it is assumed that it was added manually
                if ( $has_manual_depends ) {
                    push @tdep_manual_list, $value;
                }
            } else {
                # $value is not a R deb package so it is assumed it was added manually (like some tex packages etc.)
                if ( $value ) {
                    push @tdep_manual_list, $value;
                    $has_manual_depends = 1;
                }
            }
        }
        close($fh);
    }
}

# reset global dep list before final concatenation
@global_dep_list = ();

my $debhelper_dep = "";
my $new_compat = first { /^debhelper-compat/ } split(/\s*,\s*/m, $dsrc->{'Build-Depends'});
if (-e 'debian/compat') {
  open my $file, '<', "debian/compat";
  my $DhVersion = <$file>;
  $DhVersion =~ s/^\s+|\s+$//g;
  $debhelper_dep = "debhelper (>= $DhVersion~)";
  close $file;
  say "I: Using debhelper compat from d/compat: $debhelper_dep";
} elsif (defined $new_compat) {
  $debhelper_dep = $new_compat;
  say "I: Using debhelper compat from build-depends: $debhelper_dep";
} else {
  die "could not determine debhelper version";
}

$dsrc->{'Build-Depends'} = deps_concat("Build-Depends", $debhelper_dep, "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 (@tdep_manual_list) {
    my $empty = "";
    if ( $dsrc->{Source} !~ /^r-bioc-/) {
        $empty = substr('                              ', 0, length('Depends')+1);
    } else {
        $empty = substr('                              ', 0, length('extra_depends')+1);
    }
    if ( $rsuggests ) {
      $rsuggests = $rsuggests . ",\n$empty" . join(",\n$empty", @tdep_manual_list) ;
    } else {
      $rsuggests = join(",\n$empty", @tdep_manual_list) ;
    }
}

if ( $dsrc->{Source} !~ /^r-bioc-/) {
    # set $tctrldata->{'Depends'} only if $rsuggests is not empty
    if ( $rsuggests ) {
        $tctrldata->{'Depends'} = "@,\n         " . deps_concat("Depends", $rsuggests); # FIXME: Do not use this hackish addition of @ but teach deps_concat to add this properly
    }
}
my $output_control = 0; # Do we really need to write debian/tests/control?
if ( $dsrc->{Source} !~ /^r-bioc-/ || $rsuggests ) {
    # check for r-cran- packages whether something needs to be written
    foreach $key ('Tests', 'Depends', 'Restrictions', 'Features', 'Architecture', 'Test-Command') {
        if ( $tctrldata->{$key} ) {
            $output_control = 1;
        }
    }
    if ( $dsrc->{Source} !~ /^r-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";
        }
        open(fhtctrl, ">", $tctrl) || die "Unable to open $tctrl";
    } else {
        if ( -d tests && $dsrc->{Source} !~ /^r-bioc-/ ) {
            say "W: No tests control written despite this package is featuning a tests directory";
        }
    }
}
if ( $dsrc->{Source} !~ /^r-bioc-/) {
    foreach $key ('Tests', 'Depends', 'Restrictions', 'Features', 'Architecture', 'Test-Command') {
        if ( $tctrldata->{$key} ) {
            print fhtctrl "$key".": ".$tctrldata->{$key}."\n";
        }
    }
} else {
    # override debian/tests/autopkgtest-pkg-r.conf
    $rsuggests  =~ s/, */, \\/g;
    if ( $rsuggests ) {
        print fhtctrl "extra_depends=". $rsuggests . "\n";
        foreach $key ('extra_restrictions', 'architecture') {
            if ( $tctrldata->{$key} ) {
                print fhtctrl "$key"."=".$tctrldata->{$key}."\n";
            }
        }
    } else {
        say "I: No Suggests specified in DESCRIPTION thus not writing $tctrl" ;
    }
}
if ( $output_control || $rsuggests ) {
    close(fhtctrl);
}

# this will contain all build dependencies, but we don't want to remove
# binary dependencies which are also build dependencies
@global_dep_list = ();

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

# because unmanaged() calls deps_concat(), global_dep_list will already be populated
# and then dependencies will get de-duplicated when called again
@global_dep_list = ();

$dbin->{Depends} = deps_concat("Depends", "\${R:Depends}", $compiled ? "\${shlibs:Depends}" : "", "\${misc:Depends}", $unmanaged_depends);
$dbin->{Recommends} = deps_concat("Recommends", "\${R:Recommends}", $unmanaged_recommends);
$dbin->{Suggests} = deps_concat("Suggests", "\${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";
$dctrl->output($fh);
close($fh);

if ( $control_found_where_autopkgtest_pkg_r_conf_is_expected ) {
    die "E: debian/tests/control was found in BioConductor package.  Please remove this manually."
}

__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.