#!/usr/bin/perl -w
#
# 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.
#
# Should be run from the top level of the Lintian source tree or with
# LINTIAN_ROOT set appropriately.

use strict;
use warnings;
use autodie;

use POSIX qw(strftime);

BEGIN {
    my $LINTIAN_ROOT = $ENV{'LINTIAN_ROOT'};
    if (not $LINTIAN_ROOT) {
        require Cwd;
        $ENV{'LINTIAN_ROOT'} = $LINTIAN_ROOT = Cwd::cwd();
    } else {
        chdir($LINTIAN_ROOT);
    }
}

my $LINTIAN_ROOT = $ENV{'LINTIAN_ROOT'};

use lib "$ENV{'LINTIAN_ROOT'}/lib";
use Lintian::Deb822Parser qw(read_dpkg_control);

# Check that we're being run from the right place (although the above probably
# died if we weren't).
unless (-f 't/runtests') {
    warn "update-coverage source be run from the top level of the Lintian\n";
    warn "source tree.\n\n";
    die "Cannot find t/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(' ', $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) * 100 : '';
my $ltcr = $total ? sprintf ' (%.02f%%)', ($ltc / $total) * 100 : '';
my $ctcr
  = $check_total
  ? sprintf ' (%.02f%%)', ($ctc / $check_total) * 100
  : '';
my $cltcr
  = $check_total
  ? sprintf ' (%.02f%%)', ($cltc / $check_total) * 100
  : '';
# Open COVERAGE and print out a date stamp.
open(my $coverage, '>', 't/COVERAGE') or die "Cannot create t/COVERAGE: $!\n";
print {$coverage} 'Last generated ', strftime('%Y-%m-%d', gmtime), "\n";
print {$coverage} "Coverage (Tags): $tc/$total$tcr, ",
  "w. legacy tests: $ltc/$total$ltcr\n";
print {$coverage} "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} "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}
  "\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}
  "\nBreakdown of remaining tags in legacy test suite by test case:\n";
for my $package (sort keys %legacy_test) {
    print {$coverage} "\n$package\n";
    for my $tag (sort @{ $legacy_test{$package} }) {
        print {$coverage} "  $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]);
    }
    @untested = sort { $a->[0] cmp $b->[0] || $a->[1] cmp $b->[1] } @untested;
    my $last = '';
    for my $data (@untested) {
        my ($file, $tag) = @$data;
        if ($file ne $last) {
            print {$out} "\n";
            $last = $file;
        }
        print {$out} "$file $tag\n";
    }
    return;
}

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

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

    open(my $tag_fd, '<', $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
