#!/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::Util 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;
my %checks;
my $total;
my $check_total;
my ($tc, $ltc);
my ($ctc, $cltc);
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 ('t/tests/*/desc t/changes/*.desc t/debs/*/desc t/source/*/desc')) {
    my ($data) = read_dpkg_control($desc);
    if (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 $tagfile (glob ('testset/tags.*')) {
    next if $tagfile =~ /\.sed$/;
    my $case = $tagfile;
    $case =~ s/.*tags\.//;
    $legacy_test{$case} ||= [];
    open(my $tag_fd, '<', $tagfile);
    local $_;
    while (<$tag_fd>) {
        if (/^.: \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{$case} }, $tag);
            }
        }
    }
    close($tag_fd);
}

$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;
}

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