#!/usr/bin/perl
#
# Copyright © 2018 Chris Lamb <lamby@debian.org>
#
# Check all tags mentioned in Test-For in the new test suite and all tags seen
# by the old test suite against the list of all documented tags and generate
# output suitable for tags-never-seen that lists the untested tags.  Updates
# t/COVERAGE.

use v5.20;
use warnings;
use utf8;

use Const::Fast;
use Cwd qw(realpath);
use File::Basename qw(dirname);
use Unicode::UTF8 qw(encode_utf8);

# neither Path::This nor lib::relative are in Debian
use constant THISFILE => realpath __FILE__;
use constant THISDIR => dirname realpath __FILE__;

# use Lintian modules that belong to this program
use lib THISDIR . '/../lib';

use POSIX qw(strftime);

use Lintian::Deb822::Parser qw(read_dpkg_control);

const my $EMPTY => q{};
const my $SPACE => q{ };
const my $PERCENTAGE => 100;

$ENV{LINTIAN_BASE} = realpath(THISDIR . '/..')
  // die encode_utf8('Cannot resolve LINTIAN_BASE');

# Check that we're being run from the right place (although the above probably
# died if we weren't).
unless (-e 'private/runtests') {
    warn encode_utf8(
        "update-coverage source be run from the top level of the Lintian\n");
    warn encode_utf8("source tree.\n\n");
    die encode_utf8(
        "Cannot find private/runtests -- run from the right directory?\n");
}

# Gather a list of all tags.
my (%tags, %checks, $total, $check_total);
my ($tc, $ltc, $ctc, $cltc);
my @legacy_in_new;

for my $desc (glob('checks/*.desc')) {
    for my $data (read_dpkg_control($desc)) {
        $desc =~ s{.*/}{};
        $desc =~ s/\.desc$//;
        if (exists $data->{Tag}) {
            $tags{$data->{Tag}} = $desc;
            $checks{$desc}++;
        }
    }
}
$total = scalar keys %tags;
$check_total = scalar keys %checks;

# Parse all test configuration files from the new test suite looking for
# Test-For configuration options and remove those from the %tags hash.
for my $desc (
    glob(
        join(q{ },
            't/tests/*/desc', 't/changes/*.desc',
            't/debs/*/desc', 't/source/*/desc'))
) {
    my ($data) = read_dpkg_control($desc);
    my $testname = $data->{'Testname'};
    if ($testname =~ s{\A legacy- }{}xsm) {
        my $tagfile = $desc;
        $tagfile =~ s{ /desc \Z}{/tags}xsm;
        push(@legacy_in_new, [$testname, $tagfile]);

    } elsif (exists $data->{'Test-For'}) {
        for my $tag (split($SPACE, $data->{'Test-For'})) {
            my $check = $tags{$tag};
            delete $tags{$tag};
            if ($check) {
                delete $checks{$check} unless --$checks{$check};
            }
        }
    }
}

$tc = $total - scalar keys %tags;
$ctc = $check_total - scalar keys %checks;

# Now parse all tags files from the old test suite looking for what tags that
# test reveals.
my (%legacy, %legacy_test);
for my $deferred (@legacy_in_new) {
    my ($testname, $tagfile) = @{$deferred};
    add_legacy_tags($testname, $tagfile);
}
for my $tagfile (glob('testset/tags.*')) {
    next if $tagfile =~ /\.sed$/;
    my $case = $tagfile;
    $case =~ s/.*tags\.//;
    add_legacy_tags($case, $tagfile);
}

$ltc = $total - scalar keys %tags;
$cltc = $check_total - scalar keys %checks;

my $tcr = $total ? sprintf ' (%.02f%%)', ($tc / $total) * $PERCENTAGE : $EMPTY;
my $ltcr
  = $total
  ? sprintf ' (%.02f%%)', ($ltc / $total) * $PERCENTAGE
  : $EMPTY;
my $ctcr
  = $check_total
  ? sprintf ' (%.02f%%)', ($ctc / $check_total) * $PERCENTAGE
  : $EMPTY;
my $cltcr
  = $check_total
  ? sprintf ' (%.02f%%)', ($cltc / $check_total) * $PERCENTAGE
  : $EMPTY;
# Open COVERAGE and print out a date stamp.
open(my $coverage, '>', 't/COVERAGE')
  or die encode_utf8("Cannot create t/COVERAGE: $!\n");
print {$coverage}
  encode_utf8('Last generated ', strftime('%Y-%m-%d', gmtime), "\n");
print {$coverage} encode_utf8(
    "Coverage (Tags): $tc/$total$tcr, ",
    "w. legacy tests: $ltc/$total$ltcr\n"
);
print {$coverage} encode_utf8(
    "Coverage (Checks): $ctc/$check_total$ctcr, ",
    "w. legacy tests: $cltc/$check_total$cltcr\n\n"
);

# Whatever is left in the %tags hash are untested.  Print them out sorted by
# checks file.
print {$coverage}
  encode_utf8("The following tags are not tested by the test suite:\n");
print_tags(\%tags, $coverage);

# The contents of the %legacy hash are only tested by the legacy test suite.
print {$coverage}
  encode_utf8(
    "\nThe following tags are only tested by the legacy test suite:\n");
print_tags(\%legacy, $coverage);

# Print out a breakdown of the tags that are only tested by the legacy test
# suite, sorted by legacy test case.
print {$coverage}
  encode_utf8(
    "\nBreakdown of remaining tags in legacy test suite by test case:\n");
for my $package (sort keys %legacy_test) {
    print {$coverage} encode_utf8("\n$package\n");
    for my $tag (sort @{ $legacy_test{$package} }) {
        print {$coverage} encode_utf8("  $tag\n");
    }
}
close($coverage);

# -----------------------------------

# Given a reference to a hash whose keys are tags and whose values are file
# names, print out a report to the provide output file handle.
sub print_tags {
    my ($tags, $out) = @_;

    my @untested;
    for my $tag (keys %{$tags}) {
        push(@untested, [$tags->{$tag}, $tag]);
    }

    my @sorted = sort { $a->[0] cmp $b->[0] || $a->[1] cmp $b->[1] } @untested;

    my $final = $EMPTY;
    for my $data (@sorted) {
        my ($file, $tag) = @{$data};
        if ($file ne $final) {
            print {$out} encode_utf8("\n");
            $final = $file;
        }
        print {$out} encode_utf8("$file $tag\n");
    }

    return;
}

sub add_legacy_tags {
    my ($testname, $tagfile) = @_;

    $legacy_test{$testname} ||= [];

    open(my $tag_fd, '<', $tagfile)
      or die encode_utf8("Cannot open $tagfile");

    while (my $line = <$tag_fd>) {
        if ($line =~ /^.: \S+(?: (?:changes|source|udeb))?: (\S+)/) {
            my $tag = $1;
            if (exists $tags{$tag}) {
                my $check = $tags{$tag};
                delete $checks{$check} unless --$checks{$check};
                $legacy{$tag} = $tags{$tag};
                delete $tags{$tag};
                push(@{ $legacy_test{$testname} }, $tag);
            }
        }
    }
    close($tag_fd);
    return;
}

# Local Variables:
# indent-tabs-mode: nil
# cperl-indent-level: 4
# End:
# vim: syntax=perl sw=4 sts=4 sr et
