#!/usr/bin/perl

# Copyright © 1998 Richard Braakman
# Copyright © 2008 Frank Lichtenheld
# Copyright © 2008 Russ Allbery
#
# 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, you can find it on the World Wide
# Web at http://www.gnu.org/copyleft/gpl.html, or write to the Free
# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
# MA 02110-1301, USA.

# The harness for Lintian's new test suite.  Normally run through the runtests
# or check-tag targets in debian/rules.  For detailed information on the test
# suite layout and naming conventions, see t/tests/README.
#
# The build output is directed to build.pkgname in the testing-directory.

use strict;
use warnings;

use Data::Dumper;
use Getopt::Long qw(GetOptions);
use Text::Template;

BEGIN {
    my $LINTIAN_ROOT = $ENV{'LINTIAN_ROOT'};
    if (not $LINTIAN_ROOT) {
	use Cwd ();
	$ENV{'LINTIAN_ROOT'} = $LINTIAN_ROOT = Cwd::cwd();
    }
    delete $ENV{'LINTIAN_CFG'};
    delete $ENV{'LINTIAN_LAB'};
    delete $ENV{'LINTIAN_DIST'};
    delete $ENV{'LINTIAN_UNPACK_LEVEL'};
    $ENV{'LC_COLLATE'} = 'C';

    # Set standard umask because many of the test packages rely on this
    # when creating files from the debian/rules script.
    umask(022);
}

use lib "$ENV{'LINTIAN_ROOT'}/lib";
use Util;
use Tags;

# --- Global configuration

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

our $LINTIAN = $LINTIAN_ROOT . '/frontend/lintian';
our $DPKG_BUILDPACKAGE = 'dpkg-buildpackage -rfakeroot -us -uc -d'
    . ' -iNEVER_MATCH_ANYTHING -INEVER_MATCH_ANYTHING';
our $STANDARDS_VERSION = '3.8.3';

# --- Usage information

sub usage {
    print unquote(<<"END");
:       Usage: $0 [-dkv] <testset-directory> <testing-directory> [<test>]
:              $0 [-dkv] [-t <tag>] <testset-directory> <testing-directory>
:
:         -d        Display additional debugging information
:         -k        Do not stop after one failed test
:         -t <tag>  Run only tests for or against <tag>
:         -v        Be more verbose
:
:       The optional 3rd parameter causes runtests to only run that particular
:       test.
END
    exit 2;
}

# --- Parse options and arguments

our $DEBUG = 0;
our $VERBOSE = 0;
our $RUNDIR;
our $TESTSET;

my ($run_all_tests, $tag);
Getopt::Long::Configure('bundling');
GetOptions('d|debug'      => \$DEBUG,
	   'k|keep-going' => \$run_all_tests,
	   't|tag=s'      => \$tag,
	   'v|verbose'    => \$VERBOSE) or usage;
if ($#ARGV < 1 || $#ARGV > 2) {
    usage;
}
my $singletest;
($TESTSET, $RUNDIR, $singletest) = @ARGV;
if ($tag and $singletest) {
    usage;
}
unless (-d $RUNDIR) {
    fail("test directory $RUNDIR does not exist");
}
unless (-d $TESTSET) {
    fail("test set directory $TESTSET does not exist");
}

# --- Display output immediately

$| = 1;

# --- Exit status for the test suite driver

# Exit codes:
# 0 - success
# 1 - one or more tests failed
# 2 - an error prevented proper running of the tests
my $status = 0;

# If we don't run any tests, we'll want to warn that we couldn't find
# anything.
my $tests_run = 0;

my @tests;
my $prev;

# --- Run all test scripts

if ($singletest) {
    my $script = "$TESTSET/scripts/$singletest.t";
    if (-f $script) {
	@tests = ($script);
    }
} elsif (not $tag) {
    unless (-d "$TESTSET/scripts") {
	fail("cannot find $TESTSET/scripts: $!");
    }
    @tests = ("$TESTSET/scripts");
}

if (@tests) {
    print "Test scripts:\n";
    if (system('prove', '-r', '-I', "$LINTIAN_ROOT/lib", @tests) != 0) {
	exit 1 unless $run_all_tests;
	$status = 1;
    }
    $tests_run++;

    print "\n";
}

# --- Run all changes tests

$prev = scalar(@tests);
@tests = ();
if ($singletest) {
    my $test = $singletest;
    $test =~ s/\.changes$//;
    if (-f "$TESTSET/changes/$test.changes") {
	@tests = ($test);
    }
} elsif ($tag) {
    @tests = find_changes_for_tag($tag);
} else {
    unless (-d "$TESTSET/changes") {
	fail("cannot find $TESTSET/changes: $!");
    }
    @tests = map {
	s,^\Q$TESTSET/changes/\E,,;
	s/\.changes$//;
	$_;
    } sort(<$TESTSET/changes/*.changes>);
}
print "Found the following changes tests: @tests\n" if $DEBUG;
print "Changes tests:\n" if @tests;
for (@tests) {
    my $okay = test_changes($_);
    unless ($okay) {
	exit 1 unless $run_all_tests;
	$status = 1;
    }
    $tests_run++;
}

# --- Run all debs tests

$prev = $prev || scalar(@tests);
@tests = ();
if ($singletest) {
    my $test = $singletest;
    if (-d "$TESTSET/debs/$test") {
	@tests = ($test);
    }
} elsif ($tag) {
    @tests = find_debs_for_tag($tag);
} else {
    unless (-d "$TESTSET/debs") {
	fail("cannot find $TESTSET/debs: $!");
    }
    @tests = map {
	if (-d $_) {
	    s,^\Q$TESTSET/debs/\E,,;
	    $_;
	} else {
	    ();
	}
    } sort(<$TESTSET/debs/*>);
}
if ($prev and @tests) {
    print "\n";
    $prev = 0;
}
print "Found the following debs tests: @tests\n" if $DEBUG;
print "Raw Debian package tests:\n" if @tests;
for (@tests) {
    my $okay = test_deb($_);
    unless ($okay) {
	exit 1 unless $run_all_tests;
	$status = 1;
    }
    $tests_run++;
}

# --- Run all source tests

$prev = $prev || scalar(@tests);
@tests = ();
if ($singletest) {
    my $test = $singletest;
    if (-d "$TESTSET/source/$test") {
	@tests = ($test);
    }
} elsif ($tag) {
    @tests = find_source_for_tag($tag);
} else {
    unless (-d "$TESTSET/source") {
	fail("cannot find $TESTSET/source: $!");
    }
    @tests = map {
	if (-d $_) {
	    s,^\Q$TESTSET/source/\E,,;
	    $_;
	} else {
	    ();
	}
    } sort(<$TESTSET/source/*>);
}
if ($prev and @tests) {
    print "\n";
    $prev = 0;
}
print "Found the following source tests: @tests\n" if $DEBUG;
print "Raw Debian source package tests:\n" if @tests;
for (@tests) {
    my $okay = test_source($_);
    unless ($okay) {
	exit 1 unless $run_all_tests;
	$status = 1;
    }
    $tests_run++;
}

# --- Run all package tests

$prev = $prev || scalar(@tests);
@tests = ();
if ($singletest) {
    my $desc = "$TESTSET/tests/$singletest/desc";
    if (-f $desc) {
	@tests = read_dpkg_control($desc);
    }
} elsif ($tag) {
    @tests = find_tests_for_tag($tag);
} else {
    unless (-d $TESTSET) {
	fail("cannot find $TESTSET: $!");
    }
    @tests = map { read_dpkg_control($_) } <$TESTSET/tests/*/desc>;
}
@tests = sort {
    $a->{sequence} <=> $b->{sequence}
	|| $a->{testname} cmp $b->{testname}
    } @tests;
print "\n" if ($prev and @tests);
if ($DEBUG) {
    print "Found the following tests: ";
    print join(' ', map { $_->{testname} } @tests);
    print "\n";
}
print "Package tests:\n" if @tests;
for my $test (@tests) {
    my $okay = test_package($test);
    unless ($okay) {
	exit 1 unless $run_all_tests;
	$status = 1;
    }
    $tests_run++;
}

# --- Check whether we ran any tests

if (!$tests_run) {
    if ($singletest) {
	print "W: No tests run, did you specify a valid test name?\n";
    } elsif ($tag) {
	print "I: No tests found for that tag.\n";
    } else {
	print "E: No tests run, did you specify a valid testset directory?\n";
    }
}
exit $status;

# --- Full package testing

# Find all tests that check a particular tag, either for its presence or
# absence.  Returns a list of names of the *.desc files, without the *.desc at
# the end.
sub find_tests_for_tag {
    my ($tag) = @_;
    my @tests;
    for my $desc (<$TESTSET/tests/*/desc>) {
	my ($data) = read_dpkg_control($desc);
	if ($data->{'test-for'}) {
	    my %for = map { $_ => 1 } split(' ', $data->{'test-for'});
	    if ($for{$tag}) {
		push (@tests, $data);
		next;
	    }
	}
	if ($data->{'test-against'}) {
	    my %against = map { $_ => 1 } split(' ', $data->{'test-against'});
	    if ($against{$tag}) {
		push (@tests, $data);
	    }
	}
    }
    return @tests;
}

# Run a package test and show any diffs in the expected tags or any other
# errors detected.  Takes the description data for the test.  Returns true if
# the test passes and false if it fails.
sub test_package {
    my ($testdata) = @_;

    check_test_is_sane($TESTSET, $testdata);
    print "Running test $testdata->{testname} $testdata->{version}... ";

    my $pkg = $testdata->{srcpkg};
    my $pkgdir = "$pkg-$testdata->{version}";
    my $origdir = "$TESTSET/tests/$testdata->{testname}";
    my $targetdir = "$RUNDIR/$pkgdir";
    my $tmpldir = "$TESTSET/templates";

    my $is_native = ($testdata->{type} eq 'native');
    my $orig_version = $testdata->{version};

    # Strip the Debian revision off of the name of the target directory and
    # the *.orig.tar.gz file if the package is non-native.  Otherwise, it
    # confuses dpkg-source, which then fails to find the upstream tarball and
    # builds a native package.
    unless ($is_native) {
	for ($orig_version, $pkgdir, $targetdir) {
	    s/-[^-]+$//;
	    s/(-|^)(\d+):/$1/;
	}
    }

    print "Cleaning up and repopulating $targetdir...\n" if $DEBUG;
    runsystem_ok("rm", "-rf", $targetdir);
    my $skel = $testdata->{skeleton};
    if ($is_native) {
	runsystem("cp", "-rp", "$tmpldir/$skel", $targetdir);
	runsystem("rm", "-f", "$targetdir/debian/changelog");
	runsystem("rsync", "-rpc", "$origdir/debian/", "$targetdir/")
	    if -d "$origdir/debian/";
    } else {
	runsystem("cp", "-rp", "$tmpldir/${skel}.upstream", $targetdir);
	runsystem("rm", "-f", "$targetdir/.dummy");
	runsystem("rsync", "-rpc", "$origdir/upstream/", "$targetdir/");
	if (-x "$origdir/pre_upstream") {
	    print "running pre_upstream hook... " if $VERBOSE;
	    runsystem("$origdir/pre_upstream", $targetdir);
	}
	runsystem("cd $RUNDIR && ".
		  "tar czf ${pkg}_${orig_version}.orig.tar.gz $pkgdir");
	runsystem("rsync", "-rpc", "--exclude=debian/changelog",
		  "$tmpldir/$skel/", "$targetdir/");
	runsystem("rsync", "-rpc", "$origdir/debian/", "$targetdir/")
	    if -d "$origdir/debian/";
    }

    unless (-e "$targetdir/debian/changelog") {
	fill_in_tmpl("$targetdir/debian/changelog", $testdata);
    }
    unless (-e "$targetdir/debian/control") {
	fill_in_tmpl("$targetdir/debian/control", $testdata);
    }
    unless ($is_native || -e "$targetdir/debian/watch") {
	runsystem("echo >$targetdir/debian/watch");
    }
    if (-x "$origdir/pre_build") {
	print "running pre_build hook... " if $VERBOSE;
	runsystem("$origdir/pre_build", $targetdir);
    }

    print "building... ";
    runsystem("cd $RUNDIR/$pkgdir && $DPKG_BUILDPACKAGE >../build.$pkg 2>&1");

    my $epochless_ver = $testdata->{version};
    $epochless_ver =~ s/^(\d+)://;
    print "testing... ";
    runsystem_ok("$LINTIAN $testdata->{options} $RUNDIR/$pkg\_$epochless_ver*.changes".
		 " 2>&1 | sort > $RUNDIR/tags.$pkg");

    # Run a sed-script if it exists, for tests that have slightly variable
    # output
    runsystem_ok("sed -ri -f $origdir/post_test $RUNDIR/tags.$pkg")
	if -e "$origdir/post_test";

    # Compare the output to the expected tags.
    my $testok = runsystem_ok(qw(cmp -s), "$RUNDIR/tags.$pkg", "$origdir/tags");
    if ($testok) {
	print "ok.\n";
    } else {
	print "FAILED:\n";
	runsystem_ok("diff", "-u", "$origdir/tags", "$RUNDIR/tags.$pkg");
	return;
    }

    # Check the output for invalid lines.  Also verify that all Test-For tags
    # are seen and all Test-Against tags are not.
    my %test_for = map { $_ => 1 } split(' ', $testdata->{'test-for'});
    my %test_against = map { $_ => 1 } split(' ', $testdata->{'test-against'});
    my $okay = 1;
    open TAGS, "$RUNDIR/tags.$pkg" or fail("Cannot open $RUNDIR/tags.$pkg");
    while (<TAGS>) {
	next if m/^N: /;
	if (not /^(.): (\S+)(?: (?:source|udeb))?: (\S+)/) {
	    print "E: Invalid line:\n$_";
	    $okay = 0;
	    next;
	}
	my $tag = $3;
	if ($test_against{$tag}) {
	    print "E: Tag $tag seen but listed in Test-Against\n";
	    $okay = 0;
	}
	delete $test_for{$tag};
    }
    close TAGS;
    if (%test_for) {
	for my $tag (sort keys %test_for) {
	    print "E: Tag $tag listed in Test-For but not found\n";
	    $okay = 0;
	}
    }
    return 1 if $okay;
    return;
}

# --- Changes file testing

# Find all changes tests that check a particular tag, either for its presence
# or absence.  Returns a list of check names.
sub find_changes_for_tag {
    my ($tag) = @_;
    my @tests;
    for my $test (<$TESTSET/changes/*.tags>) {
	my ($testname) = ($test =~ m,.*/([^/]+)\.tags$,);
	open(TAGS, '<', $test) or fail("Cannot open $test");
	local $_;
	while (<TAGS>) {
	    next if /^N: /;
	    if (not /^.: \S+(?: (?:source|udeb))?: (\S+)/) {
		next;
	    }
	    if ($1 eq $tag) {
		push(@tests, $testname);
		last;
	    }
	}
	close TAGS;
    }
    return @tests;
}

# Run a test on a changes file and show any diffs in the expected tags or any
# other errors detected.  Takes the test name.  Returns true if the test
# passes and false if it fails.
sub test_changes {
    my ($test) = @_;
    print "Running test $test... ";

    my $testdir = "$TESTSET/changes";

    print "testing... ";
    runsystem_ok("$LINTIAN -I -E $testdir/$test.changes 2>&1".
		 " | sort > $RUNDIR/tags.changes-$test");

    # Compare the output to the expected tags.
    my $testok = runsystem_ok('cmp', '-s', "$testdir/$test.tags",
			      "$RUNDIR/tags.changes-$test");
    if ($testok) {
	print "ok.\n";
	return 1;
    } else {
	print "FAILED:\n";
	runsystem_ok("diff", "-u", "$testdir/$test.tags",
		     "$RUNDIR/tags.changes-$test");
	return;
    }
}

# --- Raw Debian package testing

# Find all debs tests that check a particular tag, either for its presence
# or absence.  Returns a list of check names.
sub find_debs_for_tag {
    my ($tag) = @_;
    my @tests;
    for my $test (<$TESTSET/debs/*/tags>) {
	my ($testname) = ($test =~ m,.*/([^/]+)/tags$,);
	open(TAGS, '<', $test) or fail("Cannot open $test");
	local $_;
	while (<TAGS>) {
	    next if /^N: /;
	    if (not /^.: \S+(?: (?:source|udeb))?: (\S+)/) {
		next;
	    }
	    if ($1 eq $tag) {
		push(@tests, $testname);
		last;
	    }
	}
	close TAGS;
    }
    return @tests;
}

# Run a test on a .deb file and show any diffs in the expected tags or any
# other errors detected.  Takes the test name.  Returns true if the test
# passes and false if it fails.
sub test_deb {
    my ($test) = @_;
    print "Running test $test... ";

    my $testdir = "$TESTSET/debs/$test";
    my $targetdir = "$RUNDIR/$test";

    print "Cleaning up and repopulating $targetdir...\n" if $DEBUG;
    runsystem_ok("rm", "-rf", $targetdir);
    runsystem("cp", "-rp", $testdir, $targetdir);

    print "building... ";
    runsystem("cd $targetdir && fakeroot make >../build.$test 2>&1");

    print "testing... ";
    runsystem_ok("$LINTIAN -I -E $targetdir/$test.deb 2>&1" .
		 " | sort > $RUNDIR/tags.$test");

    # Compare the output to the expected tags.
    my $testok = runsystem_ok('cmp', '-s', "$testdir/tags",
			      "$RUNDIR/tags.$test");
    if ($testok) {
	print "ok.\n";
	return 1;
    } else {
	print "FAILED:\n";
	runsystem_ok("diff", "-u", "$testdir/tags", "$RUNDIR/tags.$test");
	return;
    }
}

# --- Raw Debian source package testing

# Find all source tests that check a particular tag, either for its presence
# or absence.  Returns a list of check names.
sub find_source_for_tag {
    my ($tag) = @_;
    my @tests;
    for my $test (<$TESTSET/source/*/tags>) {
	my ($testname) = ($test =~ m,.*/([^/]+)/tags$,);
	open(TAGS, '<', $test) or fail("Cannot open $test");
	local $_;
	while (<TAGS>) {
	    next if /^N: /;
	    if (not /^.: \S+(?: (?:source|udeb))?: (\S+)/) {
		next;
	    }
	    if ($1 eq $tag) {
		push(@tests, $testname);
		last;
	    }
	}
	close TAGS;
    }
    return @tests;
}

# Run a test on a source package and show any diffs in the expected tags or
# any other errors detected.  Takes the test name.  Returns true if the test
# passes and false if it fails.
sub test_source {
    my ($test) = @_;
    print "Running test $test... ";

    my $testdir = "$TESTSET/source/$test";
    my $targetdir = "$RUNDIR/$test";

    print "Cleaning up and repopulating $targetdir...\n" if $DEBUG;
    runsystem_ok("rm", "-rf", $targetdir);
    runsystem("cp", "-rp", $testdir, $targetdir);

    print "building... ";
    runsystem("cd $targetdir && make >../build.$test 2>&1");

    print "testing... ";
    runsystem_ok("$LINTIAN -I -E $targetdir/*.dsc 2>&1" .
		 " | sort > $RUNDIR/tags.$test");

    # Compare the output to the expected tags.
    my $testok = runsystem_ok('cmp', '-s', "$testdir/tags",
			      "$RUNDIR/tags.$test");
    if ($testok) {
	print "ok.\n";
	return 1;
    } else {
	print "FAILED:\n";
	runsystem_ok("diff", "-u", "$testdir/tags", "$RUNDIR/tags.$test");
	return;
    }
}

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

# Unquote a heredoc, used to make them a bit more readable in Perl code.
sub unquote {
    my ($string) = @_;
    $string =~ s/^:( {0,7}|\t)//gm;
    return $string
}

sub runsystem {
    print "runsystem(@_)\n" if $DEBUG;
    system(@_) == 0
	or fail("failed: @_\n");
}

sub runsystem_ok {
    print "runsystem_ok(@_)\n" if $DEBUG;
    my $errcode = system(@_);
    $errcode == 0 or $errcode == (1 << 8)
	or fail("failed: @_\n");
    return $errcode == 0;
}

sub fill_in_tmpl {
    my ($file, $data) = @_;
    my $tmpl = "$file.in";

    my $template = Text::Template->new(TYPE => 'FILE',  SOURCE => $tmpl);
    open my $out, '>', $file
	or fail("cannot open $file: $!");

    unless ($template->fill_in(OUTPUT => $out, HASH => $data)) {
	fail("cannout create $file");
    }
    close $out;
}

sub check_test_is_sane {
    my ($dir, $data) = @_;

    if ($DEBUG) {
	print "check_test_is_sane <= " . Dumper($data);
    }

    unless ($data->{testname} && $data->{version}) {
	fail("Name or Version missing");
    }

    $data->{srcpkg} ||= $data->{testname};
    $data->{type} ||= 'native';
    $data->{date} ||= `date -R`; chomp $data->{date};
    $data->{description} ||= 'No Description Available';
    $data->{author} ||= 'Debian Lintian Maintainers <lintian-maint@debian.org>';
    $data->{architecture} ||= 'all';
    $data->{section} ||= 'devel';
    $data->{'standards_version'} ||= $STANDARDS_VERSION;

    $data->{'test-for'} ||= '';
    $data->{'test-against'} ||= '';

    $data->{skeleton} ||= 'skel';
    $data->{options} ||= '-I -E';

    if ($DEBUG) {
	print "check_test_is_sane => ".Dumper($data);
    }
}

# Local Variables:
# indent-tabs-mode: t
# cperl-indent-level: 4
# End:
# vim: ts=8 sw=4
