#!/usr/bin/perl

# Copyright © 1998 Richard Braakman
# Copyright © 2008 Frank Lichtenheld
# Copyright © 2008, 2009 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 threads;
use Thread::Queue;

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 Lintian::Command qw(spawn);
use Util;

# --- 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.9.1';
our $ARCHITECTURE = `dpkg-architecture -qDEB_HOST_ARCH`;
chomp $ARCHITECTURE;

# --- Usage information

sub usage {
    print unquote(<<"END");
:       Usage: $0 [-dkv] [-j [<jobs>]] <testset-directory> <testing-directory> [<test>]
:              $0 [-dkv] [-j [<jobs>]] [-t <tag>] <testset-directory> <testing-directory>
:
:         -d          Display additional debugging information
:         -j [<jobs>] Run up to <jobs> jobs in parallel. Defaults to two.
:                     If -j is passed without specifying <jobs>, the number
:                     of jobs started is <cpu cores>+1 if /proc/cpuinfo is readable.
:         -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;
our $JOBS = -1;
our $DUMP_LOGS = '';

my ($run_all_tests, $tag);
Getopt::Long::Configure('bundling');
GetOptions('d|debug'      => \$DEBUG,
	   'j|jobs:i'     => \$JOBS,
	   'k|keep-going' => \$run_all_tests,
	   't|tag=s'      => \$tag,
	   'dump-logs!'   => \$DUMP_LOGS,
	   '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");
}

# Getopt::Long assigns 0 as default value if none was specified
if ($JOBS == 0 && -r '/proc/cpuinfo') {
    open(CPU, '<', '/proc/cpuinfo')
	or fail("failed to open /proc/cpuinfo: $!");
    while (<CPU>) {
	next unless m/^cpu cores\s*:\s*(\d+)/;
	$JOBS += $1;
    }
    close(CPU);

    print "Apparent number of cores: $JOBS\n" if $DEBUG;

    # Running up to twice the number of cores usually gets the most out
    # of the CPUs and disks but it might be too aggresive to be the
    # default for -j. Only use <cores>+1 then.
    $JOBS++;
}

# No decent number of jobs? set a default
# Above $JOBS should be set to -1 so that this condition is always met,
# therefore avoiding duplication.
if ($JOBS <= 0) {
    $JOBS = 2;
}

# --- 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 :shared = 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;

my $q = Thread::Queue->new();
our $MSG_Q = Thread::Queue->new();

sub msg_flush;
sub msg_print;
sub msg_queue_handler;

# Thread to nicely handle the output of each thread:
threads->create('msg_queue_handler')->detach();

# --- 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', '-j', $JOBS, '-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;

$q->enqueue(@tests);

for (my $i = 0; $i < $JOBS; $i++) {
    threads->create(sub {
	while (my $t = $q->dequeue_nb()) {
	    my $okay = test_changes($t);
	    unless ($okay) {
		exit 1 unless $run_all_tests;
		lock($status);
		$status = 1;
	    }
	}
    });
}
$tests_run += scalar(@tests);

for my $thr (threads->list()) {
    $thr->join();
}
msg_flush;

# --- 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;

$q->enqueue(@tests);

for (my $i = 0; $i < $JOBS; $i++) {
    threads->create(sub {
	while (my $t = $q->dequeue_nb()) {
	    my $okay = test_deb($t);
	    unless ($okay) {
		exit 1 unless $run_all_tests;
		lock($status);
		$status = 1;
	    }
	}
    });
}
$tests_run += scalar(@tests);

for my $thr (threads->list()) {
    $thr->join();
}
msg_flush;

# --- 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;

$q->enqueue(@tests);

for (my $i = 0; $i < $JOBS; $i++) {
    threads->create(sub {
	while (my $t = $q->dequeue_nb()) {
	    my $okay = test_source($t);
	    unless ($okay) {
		exit 1 unless $run_all_tests;
		lock($status);
		$status = 1;
	    }
	}
    });
}
$tests_run += scalar(@tests);

for my $thr (threads->list()) {
    $thr->join();
}
msg_flush;

# --- 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 (-f "$LINTIAN_ROOT/checks/$singletest.desc"){
	@tests = map { read_dpkg_control($_) } <$TESTSET/tests/$singletest-*/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;

$q->enqueue(@tests);

for (my $i = 0; $i < $JOBS; $i++) {
    threads->create(sub {
	while (my $t = $q->dequeue_nb()) {
	    my $okay = test_package($t);
	    unless ($okay) {
		exit 1 unless $run_all_tests;
		lock($status);
		$status = 1;
	    }
	}
    });
}
$tests_run += scalar(@tests);

for my $thr (threads->list()) {
    $thr->join();
}
msg_flush;

# --- 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) = @_;

    if (!check_test_is_sane($TESTSET, $testdata)) {
	msg_print "Skipping test $testdata->{testname} $testdata->{version}... architecture mismatch\n";
	return 1;
    }

    msg_print "Running $testdata->{testname} $testdata->{version}... ";

    my $pkg = $testdata->{srcpkg};
    my $pkgdir = "$pkg-$testdata->{version}";
    my $rundir = "$RUNDIR/$pkg";
    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", $rundir);
    runsystem_ok("mkdir", "-p", $rundir);
    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") {
	    msg_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") {
	msg_print "running pre_build hook... " if $VERBOSE;
	runsystem("$origdir/pre_build", $targetdir);
    }

    msg_print "building... ";
    my $res = system("cd $rundir/$pkgdir && $DPKG_BUILDPACKAGE >../build.$pkg 2>&1");
    if ($res){
	dump_log($pkg, "$rundir/build.$pkg") if $DUMP_LOGS;
	fail("cd $rundir/$pkgdir && $DPKG_BUILDPACKAGE >../build.$pkg 2>&1");
    }

    my $version = $testdata->{version};
    $version =~ s/^(\d+)://;
    my @options = split(' ', $testdata->{options});
    my ($file) = glob("$rundir/$pkg\_$version*.changes");
    msg_print "testing... ";
    my $opts = { err => "$rundir/tags.$pkg", fail => 'never' };
    my $status;
    unshift(@options, '--allow-root');
    if ($testdata->{sort}) {
	$status = spawn($opts, [ $LINTIAN, @options, $file ], '|', [ 'sort' ]);
    } else {
	$status = spawn($opts, [ $LINTIAN, @options, $file ]);
    }
    unless ($status == 0 or $status == 1) {
	msg_print "FAILED:\n";
	fail("$LINTIAN @options $file exited with status $status\n");
    }
    open(OUT, '>>', "$rundir/tags.$pkg")
	or fail("cannot append to $rundir/tags.$pkg: $!");
    print OUT ${ $opts->{out} };
    close OUT;

    # 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) {
	msg_print "ok.\n";
    } else {
	if ($testdata->{'todo'} eq 'yes') {
	    msg_print "TODO\n";
	    return 1;
	} else {
	    msg_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.  Skip this part of the test
    # if neither Test-For nor Test-Against are set and Sort is also not set,
    # since in that case we probably have non-standard output.
    my %test_for = map { $_ => 1 } split(' ', $testdata->{'test-for'});
    my %test_against = map { $_ => 1 } split(' ', $testdata->{'test-against'});
    if (not %test_for and not %test_against and $testdata->{'output-format'} ne 'EWI') {
	if ($testdata->{'todo'} eq 'yes') {
	    msg_print "E: marked as TODO but succeeded.\n";
	    return;
	} else {
	    return 1;
	}
    } else {
	my $okay = 1;
	open TAGS, "$rundir/tags.$pkg" or fail("Cannot open $rundir/tags.$pkg");
	while (<TAGS>) {
		next if m/^N: /;
		if (not /^(.): (\S+)(?: (?:changes|source|udeb))?: (\S+)/) {
		    msg_print (($testdata->{'todo'} eq 'yes')? "TODO" : "E");
		    msg_print ": Invalid line:\n$_";
		    $okay = 0;
		    next;
		}
		my $tag = $3;
		if ($test_against{$tag}) {
		    msg_print (($testdata->{'todo'} eq 'yes')? "TODO" : "E");
		    msg_print ": 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) {
		    msg_print (($testdata->{'todo'} eq 'yes')? "TODO" : "E");
		    msg_print ": Tag $tag listed in Test-For but not found\n";
		    $okay = 0;
		}
	}
	if ($okay && $testdata->{'todo'} eq 'yes') {
	    msg_print "E: marked as TODO but succeeded.\n";
	    return;
	} else {
	    return ($okay || $testdata->{'todo'} eq 'yes');
	}
    }
}

# --- 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) = @_;
    msg_print "Running $test... ";

    my $testdir = "$TESTSET/changes";

    msg_print "testing... ";
    runsystem_ok("$LINTIAN --allow-root -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) {
	msg_print "ok.\n";
	return 1;
    } else {
	msg_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) = @_;
    msg_print "Running $test... ";

    my $testdir = "$TESTSET/debs/$test";
    my $targetdir = "$RUNDIR/$test";
    if (-f "$testdir/skip") {
	msg_print "skipped.\n";
	return 1;
    }

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

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

    msg_print "testing... ";
    runsystem_ok("$LINTIAN --allow-root -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) {
	msg_print "ok.\n";
	return 1;
    } else {
	msg_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) = @_;
    msg_print "Running $test... ";

    my $testdir = "$TESTSET/source/$test";
    my $targetdir = "$RUNDIR/$test";
    if (-f "$testdir/skip") {
	msg_print "skipped.\n";
	return 1;
    }

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

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

    msg_print "testing... ";
    runsystem_ok("$LINTIAN --allow-root -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) {
	msg_print "ok.\n";
	return 1;
    } else {
	msg_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 dump_log{
    my ($pkg, $logf) = @_;
    if (open(my $log, '<', $logf)){
	print "$pkg: ---- START BUILD LOG\n";
	print "$pkg: $_" while (<$log>);
	print "$pkg: ---- END BUILD LOG\n";
	close($log);
    } else {
	msg_print "!!! Could not dump $logf: $!";
    }
    return 1;
}

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->{sort} = ($data->{sort} and $data->{sort} eq 'no') ? 0 : 1;
    $data->{'output-format'} ||= 'EWI';

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

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

    # Unwrap the options in case we used continuation lines.
    $data->{options} =~ s/\n//g;

    # Allow options relative to the root of the test directory.
    $data->{options} =~ s/TESTSET/$dir/g;

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

    my @architectures = qw(all any);
    push @architectures, $ARCHITECTURE;

    # Check for arch-specific tests
    if (!grep { $data->{architecture} =~ m/\b$_\b/ } @architectures) {
	return 0;
    }

    return 1;
}

sub msg_flush {
    my %msg = ( id => threads->tid() );
    $MSG_Q->enqueue(\%msg);
}

sub msg_print {
    my %msg = ( id => threads->tid(), msg => "@_" );
    $MSG_Q->enqueue(\%msg);
}

sub msg_queue_handler {
    my %thrs;
    my $length = 0;

    while (my $msg = $MSG_Q->dequeue()) {
	my $id = $msg->{'id'};
	# master thread calls msg_flush to flush all messages
	if ($id == 0) {
	    for my $tid (keys %thrs) {
		my %msg = (id => $tid);
		$MSG_Q->insert(0, \%msg);
	    }
	} else {
	    if (!exists($msg->{'msg'}) && exists($thrs{$id})) {
		print (' 'x$length,"\r");
		$length = 0;
		while (my $m = shift @{$thrs{$id}}) {
		    print $m;
		}
		print "\n";
		delete $thrs{$id};
	    } elsif (exists($msg->{'msg'})) {
		$thrs{$id} = []
		    unless (exists($thrs{$id}));

		my $flush = 0;
		# We split by line. Every time a newline is found the
		# messages queue is flushed (by the above code)
		for my $line (split /(?=\n)/, $msg->{'msg'}) {
		    $flush = 1 if ($line =~ s/^\n//);
		    push @{$thrs{$id}}, $line;
		}

		# Insert a flush request, if needed
		$MSG_Q->insert(0, { id => $id }) if $flush;
	    }
	}

	# Status line: 'thr1 msg || thr2 msg || ...'
	my @output;
	for my $tid (keys %thrs) {
	    my $p = $thrs{$tid}[-1];
	    $p =~ s/\s+$//;

	    push @output, $p;
	}
	my $output = join(' || ', @output);
	printf "%-${length}s\r", $output;
	$length = length($output);
    }
}

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