#!/usr/bin/perl
#
# Guardians of the Namespace: Debian Archive Overrides Sublimator
#
# Copyright © 2013, 2017-2018 Guillem Jover <guillem@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 2 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 <https://www.gnu.org/licenses/>.

use strict;
use warnings;
use feature qw(state);

my $VERSION = '0.0';

use Getopt::Long qw(:config posix_default bundling no_ignorecase);

use AptPkg::Config '$_config';
use AptPkg::System '$_system';
use AptPkg::Cache;

(my $self = $0) =~ s#.*/##;

my %options = (
    help	=> sub { usage(); exit 0 },
    version	=> sub { version(); exit 0 },
    filter	=> undef,
    suite	=> 'experimental|unstable|sid|testing|wheezy',
    format	=> 'detail',
    chunk	=> undef,
    verbose	=> 0,
);

my $bts_from_name = (getpwuid($<))[6] =~ s/,.*$//r;
my $bts_from_mail = $ENV{DEBEMAIL};
my $bts_from = "$bts_from_name <$bts_from_mail>";
my $bts_addr = 'submit@bugs.debian.org';
my $bts_user = 'guardians@namespace.hadrons.org';
my $bts_tags = 'sectionspace-rift';

sub version
{
    print "$self $VERSION\n",
}

sub usage
{
    printf "Usage: %s [options] <file...>

Options:
      --suite=NAME	Set the suite (default: %s).
      --filter=NAME	Set the section filter to use (default: '')
      --format=NAME	Set the output format (default: %s).
                        Supported values: bts, micro, bulk, detail.
      --chunk=N		Chunk output formats by N items (default none).
      --verbose=N	Set the verbose level (default: %d).
  -?, --help		Show this help message.
      --version		Show the version.
", $self, $options{suite}, $options{format}, $options{verbose};
}

my $rc = GetOptions(\%options,
    'help|?',
    'version',
    'filter=s',
    'suite=s',
    'format=s',
    'chunk=i',
    'verbose=i',
);

usage() and exit 1 unless $rc or @ARGV;

# Initialise the global config object with the default values and
# setup the $_system object.
$_config->init;
$_system = $_config->system;

# Suppress cache building messages.
$_config->{quiet} = 2;

# Set up the cache.
my $cache = AptPkg::Cache->new;

sub header
{
    if ($options{format} eq 'bts') {
        print "From: $bts_from\n";
        print "To: $bts_addr\n";
        print 'Subject: override: ';
    }
}

sub footer
{
    if ($options{format} eq 'bts') {
        print "\n\n";
        print "Package: ftp.debian.org\n";
        print "Severity: wishlist\n";
        print "User: ftp.debian.org\@packages.debian.org\n";
        print "Usertags: override\n";
        print "User: $bts_user\n";
        print "Usertags: $bts_tags\n";
    }
}

sub skip
{
    my ($pkgname, $section, $excuse) = @_;

    return if $options{format} ne 'detail';

    print "    skip: $pkgname:$section ($excuse)\n" if $options{verbose} > 0;
}

sub relay
{
    my ($line) = @_;

    return if $options{format} ne 'detail';

    print "$line\n" if $options{verbose} > 0;
}

sub override
{
    my ($pkgname, $version, $cursection, $section, $priority) = @_;
    state $chunked = 0;

    return if defined $options{filter} and !($section =~ $options{filter});

    # Normalize priority, Debian does not have extra anymore.
    $priority = 'optional' if $priority eq 'extra';

    if ($options{format} eq 'detail') {
        print "override: $pkgname:$section/$priority ($version ; $cursection)\n";
    } elsif ($options{format} eq 'bts') {
        print "$pkgname:$section/$priority";
        $chunked++;

        if (defined $options{chunk} and $chunked >= $options{chunk}) {
            $chunked = 0;
            footer();
            print "\n<<==>>\n";
            header();
        } else {
            print ", ";
        }
    } elsif ($options{format} eq 'micro') {
        print "$pkgname $section\n";
    } elsif ($options{format} eq 'bulk') {
        print "$pkgname\t$section\t$priority\n";
    } else {
        die "format not supported $options{format}\n";
    }
}

sub check_change
{
    my ($pkgname, $section, $oldsection) = @_;

    print "D: $pkgname $section\n" if $options{verbose} > 1;

    # Patterns are not currently supported.
    if ($pkgname =~ m/\*/) {
        skip($pkgname, $section, "pattern");
        return;
    }

    my $pkg = $cache->{$pkgname};
    unless ($pkg) {
        skip($pkgname, $section, "unknown package");
        return;
    }

    my $available = $pkg->{VersionList};
    unless ($available) {
        skip($pkgname, $section, "virtual package");
        return;
    }

    my $cursection = $pkg->{Section};

    if ($cursection =~ m/^$section$/) {
        skip($pkgname, $section, "correct section ; $cursection");
        return;
    }

    if (defined $oldsection and $cursection ne $oldsection) {
        skip($pkgname, $section, "changed section ; $cursection");
        return;
    }

    my $pkg_found = 0;

    FIND_PKG: for my $v (@$available) {
        for my $f (map $_->{File}, @{$v->{FileList}}) {
            if ($f->{Archive} =~ m/$options{suite}/) {
                my $version = $v->{VerStr};
                my $priority = $v->{Priority};

                override($pkgname, $version, $cursection, $section, $priority);

                $pkg_found = 1;
                last FIND_PKG;
            }
        }
    }

    if (!$pkg_found) {
        skip($pkgname, $section, "not in suite = $options{suite}");
    }
}

header();

while (<>) {
    chomp;

    next if /^#/;

    if (/^==== finish ====/) {
        relay($_);
        last;
    }
    if (/^(?:==|--)/) {
        relay($_);
        next;
    }
    if (/^\s*$/) {
        relay('');
        next;
    }

    # Override fix proposal
    if (m{^([*a-z0-9.+-]+)\s+([a-z|/-]+)}) {
        my $pkgname = $1;
        my $section = $2;

        check_change($pkgname, $section);
        next;
    }

    # Override fix proposal w/ check
    if (m{^([*a-z0-9.+-]+)\s+!([a-z/-]+)\s+->\s([a-z|/-]+)}) {
        my $pkgname = $1;
        my $oldsection = $2;
        my $section = $3;

        check_change($pkgname, $section, $oldsection);
        next;
    }
}

footer();

1;