#!/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 autodie;

use Cwd();

use threads;
use threads::shared;
use Thread::Queue;

use Getopt::Long qw(GetOptions);
use List::MoreUtils qw(none);

use constant SUITES => qw(scripts changes debs source tests);

our ($LINTIAN_ROOT, $LINTIAN, @LINTIAN_CMD);

BEGIN {
    if (($ENV{'LINTIAN_TEST_INSTALLED'}//'no') eq 'yes') {
        $LINTIAN_ROOT = '/usr/share/lintian';
        $LINTIAN = '/usr/bin/lintian';
    } else {
        $LINTIAN_ROOT = Cwd::cwd();
        $LINTIAN = "$LINTIAN_ROOT/frontend/lintian";
    }
    $ENV{'LINTIAN_TEST_ROOT'} = $LINTIAN_ROOT;
    $ENV{'LINTIAN_FRONTEND'} = $LINTIAN;
    @LINTIAN_CMD = ($LINTIAN);

    delete $ENV{'LINTIAN_CFG'};
    delete $ENV{'LINTIAN_LAB'};
    delete($ENV{'LINTIAN_PROFILE'});
    delete($ENV{'LINTIAN_COVERAGE'});
    # Some of the tests don't cope too well with "-j" in MAKEFLAGS
    delete($ENV{'MAKEFLAGS'});
    # Ensure Lintian works without $ENV{HOME}
    delete($ENV{'HOME'});
    # Ubuntu auto-builders run pkg-mangle which messes with our
    # test packages, so ask it not to do so by default.
    $ENV{'NO_PKG_MANGLE'} = 'true'
      unless exists($ENV{'NO_PKG_MANGLE'});

    $ENV{'LC_ALL'} = '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 "$LINTIAN_ROOT/lib";

use Lintian::Internal::FrontendUtil qw(default_parallel);
use Lintian::Util qw(delete_dir fail parse_boolean
  rstrip slurp_entire_file touch_file);

use Test::Lintian::Harness qw(chdir_runcmd check_test_depends
  copy_template_dir fill_in_tmpl find_tests_for_tag
  read_test_desc runsystem runsystem_ok skip_reason up_to_date);

# --- Global configuration
our @DPKG_BUILDPACKAGE_CMD = (
    qw(dpkg-buildpackage -rfakeroot -us -uc -d),
    qw(-iNEVER_MATCH_ANYTHING -INEVER_MATCH_ANYTHING),
    qw(--source-option=--auto-commit),
);
our $STANDARDS_VERSION = '3.9.5';
our $ARCHITECTURE = `dpkg-architecture -qDEB_HOST_ARCH`;
chomp $ARCHITECTURE;

my %TEMPLATES = (
    'tests'  => ['debian/changelog', 'debian/control'],
    'debs'   => ['changelog', 'control', 'Makefile'],
    'source' => ['changelog', 'control'],
);
my $DATE = `date -R`;
chomp $DATE;

my $output_is_tty = -t STDOUT;

# --- Usage information

sub usage {
    my ($exitcode) = @_;
    print unquote(<<"END");
:       Usage: $0 [options] [-j [<jobs>]] <testset-directory> <testing-directory> [<test-selection>]
:
:         --coverage  Run Lintian under Devel::Cover (Warning: painfully slow)
:         -d          Display additional debugging information
:         --dump-logs Print build log to STDOUT, if a build fails.
:         -j [<jobs>] Run up to <jobs> jobs in parallel.
:                     If -j is passed without specifying <jobs>, the number
:                     of jobs started is <nproc>+1.
:         -k          Do not stop after one failed test
:         -v          Be more verbose
:         --help, -h  Print this help and exit
:
:       The optional 3rd parameter causes runtests to only run tests that match
:       the particular selection.  This parameter can be one of:
:
:          * <testname>
:            - Run the test(s) named exactly <testname>.  Note that each suite
:              can reuse the name of the test, so this may run more than one
:              test.
:          * <dir-in-scripts-suite>
:            - Run all "scripts"-tests within a given dir.  E.g. "01-critic"
:              will run all tests in "t/scripts/01-critic/".
:          * <check-name>
:            - Run all tests related to the given check.  This is based on the
:              name of the test (i.e. it must start with "<check-name>-").
:          * legacy
:            - Run all "legacy" tests (i.e. t/tests/legacy-*), which were
:              imported from the old test suite.
:          * suite:<suite>[,<suite...>]
:            - Run all tests in the listed suites.
:          * tag:<tag-name>
:            - Run any test that lists <tag-name> in "Test-For" or
:              "Test-Against".
:
:
:       Test artifacts are cached in <testing-directory> and will be reused if
:       deemed "up-to-date".  This cache can greatly reduce the run time of the
:       test suite.
END
    exit($exitcode//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, $coverage);
Getopt::Long::Configure('bundling');
GetOptions(
    'd|debug'      => \$DEBUG,
    'j|jobs:i'     => \$JOBS,
    'k|keep-going' => \$run_all_tests,
    'dump-logs!'   => \$DUMP_LOGS,
    'v|verbose'    => \$VERBOSE,
    'coverage:s'   => \$coverage,
    'help|h'       => sub {usage(0); },
) or usage;

if ($#ARGV < 1 || $#ARGV > 2) {
    usage;
}
my $singletest;
($TESTSET, $RUNDIR, $singletest) = @ARGV;
if (-d $RUNDIR) {
    my $abs = Cwd::abs_path($RUNDIR);
    fail("Cannot resolve $RUNDIR: $!")
      if not defined($abs);
    $RUNDIR = $abs;
} else {
    fail("test directory $RUNDIR does not exist");
}

unless (-d $TESTSET) {
    fail("test set directory $TESTSET does not exist");
}

if (defined($coverage)) {
    my $harness_perl_switches = $ENV{'HARNESS_PERL_SWITCHES'}//'';
    # Only collect coverage for stuff that D::NYTProf and
    # Test::Pod::Coverage cannot do for us.  This makes cover use less
    # RAM in the other end.
    my @criteria = qw(statement branch condition path subroutine);
    my $coverage_arg = '-MDevel::Cover=-silent,1,+ignore,^(.*/)?t/scripts/.+';
    $coverage_arg .= ',-coverage,' . join(',-coverage,', @criteria);
    $coverage_arg .= ',' . $coverage if $coverage ne '';
    $ENV{'LINTIAN_COVERAGE'} = 1;
    $harness_perl_switches .= ' ' . $coverage_arg;
    $ENV{'HARNESS_PERL_SWITCHES'} = $harness_perl_switches;
    unshift(@LINTIAN_CMD, 'perl', $coverage_arg);
}

if ($DEBUG) {
    require Data::Dumper;
    import Data::Dumper;
}

if (-d "$TESTSET/helpers/bin") {
    # Add the test helpers to PATH
    my $tpath = Cwd::abs_path("$TESTSET/helpers/bin");
    fail "Cannot resolve $TESTSET/helpers/bin: $!" unless $tpath;
    $ENV{'PATH'} = "$tpath:$ENV{'PATH'}";
}

# Getopt::Long assigns 0 as default value if none was specified
# (i.e. "-j").  Otherwise, $JOBS can also be -1 if "-j" was not
# specified at all.
if ($JOBS <= 0) {
    $JOBS = default_parallel();

    print "Doing up to $JOBS concurrent builds/tests\n" if $DEBUG;
}

# --- Display output immediately
STDOUT->autoflush;

# --- 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
# NB: Also locks $failed (as they are always updated together).
my $status :shared = 0;

# Tests that were skipped and why
# - $suite => $testname => $reason
my $skipped = shared_clone({});
# Tests that failed
# - Use $status as lock (since when $failed is updated,
#   then $status is as well)
my $failed = shared_clone([]);

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

my (%suites, @tests, $prev);

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

if ($singletest && $singletest =~ s/^tag://) {
    $tag = $singletest;
    # clear singletest to avoid find a "single" test.
    $singletest = '';
} elsif ($singletest && $singletest =~ m/^suite:(.++)/) {
    my $list = $1;
    %suites = ();
    foreach my $s (split m/\s*+,\s*+/, $list) {
        $suites{$s} = 1;
    }
    # clear singletest to avoid find a "single" test.
    $singletest = '';
} else {
    # run / check all of them
    foreach my $s (SUITES) {
        $suites{$s} = 1;
    }
}

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 (-d "$TESTSET/scripts/$singletest") {
        @tests = ("$TESTSET/scripts/$singletest");
    }
} elsif (!$tag && $suites{'scripts'}) {
    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 $desc = "$TESTSET/changes/$singletest";
    $desc =~ s/\.changes$//;
    $desc = "$desc.desc";
    if (-f $desc) {
        push @tests, read_test_desc($desc);
    }
} elsif ($tag) {
    @tests = find_tests_for_tag($tag, "$TESTSET/changes/*.desc");
} elsif ($suites{'changes'}) {
    unless (-d "$TESTSET/changes") {
        fail("cannot find $TESTSET/changes: $!");
    }
    @tests = map { read_test_desc($_) } sort(glob("$TESTSET/changes/*.desc"));
}
print "Found the following changes tests: @tests\n" if $DEBUG;
print "Changes tests:\n" if @tests;

run_tests(\&test_changes, @tests);

$tests_run += scalar(@tests);
msg_flush;

my @test_suite_info = ([
        'debs', "$TESTSET/debs/*/desc",
        sub { generic_test_runner('debs', 'deb', @_) }
    ],
    [
        'source', "$TESTSET/source/*/desc",
        sub { generic_test_runner('source', 'dsc', @_) }
    ],
    ['tests', "$TESTSET/tests/*/desc", sub { test_package('tests', @_) }]

);

foreach my $tsi (@test_suite_info) {
    my ($tdir, $globstr, $runner) = @$tsi;
    $prev = $prev || scalar(@tests);
    @tests = ();
    if ($singletest) {
        my $test = $singletest;
        if (-d "$TESTSET/$tdir/$test") {
            push @tests, read_test_desc("$TESTSET/$tdir/$test/desc");
        } elsif (-f "$LINTIAN_ROOT/checks/$singletest.desc"
            || $singletest eq 'legacy') {
            @tests = map { read_test_desc($_) }
              glob("$TESTSET/$tdir/$singletest-*/desc");
        }
    } elsif ($tag) {
        @tests = find_tests_for_tag($tag, $globstr);
    } elsif ($suites{$tdir}) {
        unless (-d "$TESTSET/$tdir/") {
            fail("cannot find $TESTSET/$tdir: $!");
        }
        @tests = map { read_test_desc($_) } glob($globstr);
    }
    @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 ($tdir):\n" if @tests;

    run_tests($runner, @tests);
    $tests_run += scalar(@tests);
    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";
    }
} else {
    if (%{$skipped}) {
        print "\nSkipped/disabled tests:\n";
        for my $suite (SUITES) {
            if (exists($skipped->{$suite})) {
                print "  [$suite]\n";
                for my $testname (sort(keys(%{ $skipped->{$suite} }))) {
                    my $reason = $skipped->{$suite}{$testname};
                    print "    $testname: $reason\n";
                }
            }
        }
    }
    if (my $number = @{$failed}) {
        print "\nFailed tests ($number)\n";
        for my $test (@{$failed}) {
            print "    $test\n";
        }
    }
}
exit $status;

# --- Full package testing

# 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 ($suite, $testdata) = @_;
    my $testname = $testdata->{testname};

    if (!check_test_is_sane($TESTSET, $testdata)) {
        return skip_test($suite, $testname, 'architecture mismatch');
    }

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

    my $pkg = $testdata->{source};
    my $rundir = "$RUNDIR/$suite/$pkg";
    my $origdir = "$TESTSET/$suite/$testname";
    my $orig_version = $testdata->{version};
    my $expected = "$origdir/tags";
    my $origexp = $expected;
    my $stampfile = "$rundir/build-stamp";
    my $epochless_version = $orig_version;
    $epochless_version =~ s/^\d+://;

    if (-f "$origdir/skip") {
        my $reason = skip_reason("$origdir/skip");
        return skip_test($suite, $testname, "(disabled) $reason");
    }

    if ($testdata->{'test-depends'}) {
        my $missing = check_test_depends($testdata);
        if ($missing) {
            return skip_test($suite, $testname,
                "Unsatisified Depends: $missing");
        }
    }

    if (not up_to_date($stampfile, $origdir)) {
        my $tmpldir = "$TESTSET/templates/$suite/";
        my $skel = $testdata->{skeleton};
        my $is_native = ($testdata->{type} eq 'native');
        my $pkgdir = "$pkg-$testdata->{version}";
        my $targetdir = "$rundir/$pkgdir";

        # 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);
        unless ($is_native) {
            copy_template_dir("$tmpldir/${skel}.upstream",
                "$origdir/upstream/",$targetdir);
            unlink "$targetdir/.dummy" if -e "$targetdir/.dummy";
            if (-x "$origdir/pre_upstream") {
                msg_print 'running pre_upstream hook... ' if $VERBOSE;
                runsystem("$origdir/pre_upstream", $targetdir);
            }
            chdir_runcmd($rundir,
                ['tar', 'czf', "${pkg}_${orig_version}.orig.tar.gz", $pkgdir]);
            if (-f "$origdir/debian/debian/source/format") {
                my $format
                  = slurp_entire_file("$origdir/debian/debian/source/format");
                chomp $format;
                if ($format =~ m/^3.\d+ \(quilt\)$/) {
                    delete_dir("$targetdir/debian/");
                }
            }
        }
        copy_template_dir("$tmpldir/$skel", "$origdir/debian/", $targetdir,
            ['--exclude=debian/changelog']);

        foreach my $tfile (@{ $TEMPLATES{$suite} }) {
            unless (-e "$targetdir/$tfile") {
                fill_in_tmpl("$targetdir/$tfile", $testdata);
            }
        }

        unless ($is_native || -e "$targetdir/debian/watch") {
            my $f = "$targetdir/debian/watch";
            # Create a watch file with "content" as lintian checks for
            # non-zero file size.
            open(my $fd, '>', $f);
            print {$fd} "# Empty watch file\n";
            close($fd);
        }
        if (-x "$origdir/pre_build") {
            msg_print 'running pre_build hook... ' if $VERBOSE;
            runsystem("$origdir/pre_build", $targetdir);
        }
        _builder_tests($testdata, "$rundir/$pkgdir", "$rundir/build.$pkg");
        touch_file($stampfile);
    } else {
        msg_print 'building (cached)... ';
    }

    my $file = "${pkg}_${epochless_version}_${ARCHITECTURE}.changes";
    run_lintian($testdata, "$rundir/$file", "$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";

    if (-x "$origdir/test_calibration") {
        my $calibrated = "$rundir/expected.$pkg.calibrated";
        msg_print 'running test_calibration hook... ' if $VERBOSE;
        runsystem_ok(
            "$origdir/test_calibration", $expected,
            "$rundir/tags.$pkg", $calibrated
        );
        $expected = $calibrated if -e $calibrated;
    }

    return _check_result($testdata, $expected, "$rundir/tags.$pkg", $origexp);
}

sub _builder_tests {
    my ($testdata, $testdir, $log) = @_;
    msg_print 'building... ';
    my $res = chdir_runcmd($testdir, \@DPKG_BUILDPACKAGE_CMD, $log);
    if ($res){
        my $pkg = $testdata->{source};
        dump_log($pkg, $log) if $DUMP_LOGS;
        fail("cd $testdir && @DPKG_BUILDPACKAGE_CMD >$log 2>&1");
    }

    return;
}

sub run_lintian {
    my ($testdata, $file, $out) = @_;
    msg_print 'testing... ';
    my @options = split(' ', $testdata->{options}//'');
    unshift(@options, '--allow-root', '--no-cfg');
    unshift(@options, '--profile', $testdata->{profile});
    unshift(@options, '--no-user-dirs');
    my $pid = open(my $in, '-|');
    if ($pid) {
        my @data = <$in>;
        my $status = 0;
        eval {close($in);};
        if (my $err = $@) {
            fail("close pipe: $!") if $err->errno;
            $status = ($? >> 8) & 255;
        }
        if (defined($coverage)) {
            # Devel::Cover causes some annoying deep recursion
            # warnings.  Filter them out, but only during coverage.
            # - This is not flawless, but it gets most of them
            @data = grep {
                !m{^Deep [ ] recursion [ ] on [ ] subroutine [ ]
                    "[^"]+" [ ] at [ ] .*B/Deparse.pm [ ] line [ ]
                   \d+}xsm
            } @data;
        }
        unless ($status == 0 or $status == 1) {
            msg_print "FAILED\n";
            for my $line (@data) {
                #NB: $line has trailing newline.
                msg_print "$testdata->{testname}: $line";
            }
            fail "@LINTIAN_CMD @options $file exited with status $status";
        } else {
            @data = sort @data if $testdata->{sort};
            open(my $fd, '>', $out);
            print $fd $_ for @data;
            close($fd);
        }
    } else {
        open(STDERR, '>&', \*STDOUT);
        exec {$LINTIAN_CMD[0]} @LINTIAN_CMD, @options, $file
          or fail "exec failed: $!";
    }
    return 1;
}

# --- Changes file testing

# 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 ($testdata) = @_;
    my $testname = $testdata->{testname};

    if (!check_test_is_sane($TESTSET, $testdata)) {
        return skip_test('changes', $testname, 'architecture mismatch');
    }

    if ($testdata->{'test-depends'}) {
        # Not sure this makes sense for .changes tests, but at least it
        # makes it consistent.
        my $missing = check_test_depends($testdata);
        if ($missing) {
            return skip_test('changes', $testname,"Missing Depends: $missing");
        }
    }

    mkdir("$RUNDIR/changes")
      if not -d "$RUNDIR/changes";

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

    my $test = $testdata->{source};
    my $testdir = "$TESTSET/changes";
    my $file = "$testdir/$test.changes";
    # Check if we need to copy these files over.
    if (!-e $file && -e "$file.in") {
        my @files;
        msg_print 'building... ';
        # copy all files but "tags" and desc.  Usually this will only
        # be ".changes.in", but in rare cases we have "other files"
        # as well.
        #
        # the _glob-call emulates glob("$testdir/$test.*")
        # (see #723805)
        @files
          = grep { !/\.(?:desc|tags)$/o } _glob($testdir, qr/\Q$test.\E.*/);
        runsystem('cp', '-f', @files, "$RUNDIR/changes");
        $file = "$RUNDIR/changes/${test}.changes";
        fill_in_tmpl($file, $testdata);
    }

    run_lintian($testdata, $file, "$RUNDIR/changes/tags.$test");

    return _check_result($testdata, "$testdir/$test.tags",
        "$RUNDIR/changes/tags.$test");
}

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

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

# generic_test_runner($dir, $ext, $test)
#
# Runs the test called $test assumed to be located in $TESTSET/$dir/$test/.
# The resulting package produced by the test is assumed to have the extension
# $ext.
#
# Returns a truth value on success, undef on test failure.  May call die/fail
# if the test is broken.
sub generic_test_runner {
    my ($suite, $ext, $testdata) = @_;
    my $testname = $testdata->{testname};

    if (!check_test_is_sane($TESTSET, $testdata)) {
        return skip_test($suite, $testname, 'architecture mismatch');
    }

    msg_print "Running $testname... ";

    my $testdir = "$TESTSET/$suite/$testname";
    my $targetdir = "$RUNDIR/$suite/$testname";
    my $stampfile = "$RUNDIR/$suite/$testname-build-stamp";

    if (-f "$testdir/skip") {
        my $reason = skip_reason("$testdir/skip");
        return skip_test($suite, $testname, "(disabled) $reason");
    }

    if ($testdata->{'test-depends'}) {
        my $missing = check_test_depends($testdata);
        if ($missing) {
            return skip_test($suite, $testname, "Missing Depends: $missing");
        }
    }

    if (not up_to_date($stampfile, $testdir)) {
        my $skel = $testdata->{skeleton};
        my $tmpldir = "$TESTSET/templates/$suite/";

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

        copy_template_dir("$tmpldir/$skel", "$testdir/", $targetdir,
            ['--exclude=changelog'], ['--exclude=desc']);

        foreach my $tfile (@{ $TEMPLATES{$suite} }) {
            unless (-e "$targetdir/$tfile") {
                fill_in_tmpl("$targetdir/$tfile", $testdata);
            }
        }

        msg_print 'building... ';
        my $res= chdir_runcmd($targetdir, ['fakeroot', 'make'],
            "../build.$testname");
        if ($res){
            dump_log($testname, "$RUNDIR/build.$testname") if $DUMP_LOGS;
            fail("cd $targetdir && fakeroot make >../build.$testname 2>&1");
        }
        touch_file($stampfile);
    } else {
        msg_print 'building (cached)...';
    }
    # The _glob call emulates glob("$targetdir/*.$ext")
    # (see #723805)
    my @matches = _glob($targetdir, qr/.*\.\Q$ext\E/);
    my $file = shift @matches;
    unless ($file && -e $file) {
        $file //= '<N/A>';
        fail join(q{ },
            "$testname did not produce any file matching",
            "\"$targetdir/*.$ext\" ($file)");
    }
    fail "$testname produced more than one file matching \"$targetdir/*.$ext\""
      if @matches;

    run_lintian($testdata, $file, "$RUNDIR/$suite/tags.$testname");
    return _check_result($testdata, "$testdir/tags",
        "$RUNDIR/$suite/tags.$testname");
}

# Makeshift replacement for "glob" to work around #723805
sub _glob {
    my ($dir, $pattern) = @_;
    my @matches;
    opendir(my $dirfd, $dir);
    for my $file (readdir($dirfd)) {
        next if $file eq '.' or $file eq '..';
        push(@matches, "$dir/$file")
          if $file =~ m{\A $pattern \Z}xsm;
    }
    closedir($dirfd);
    return @matches;
}

sub _check_result {
    my ($testdata, $expected, $actual, $origexp) = @_;
    # Compare the output to the expected tags.
    my $testok = runsystem_ok('cmp', '-s', $expected, $actual);

    if ($testok) {
        msg_print "ok.\n";
        # Continue to check the "test-for/test-against" tags
    } else {
        if ($testdata->{'todo'} eq 'yes') {
            msg_print "TODO\n";
            return 1;
        } else {
            msg_print "FAILED\n";
            runsystem_ok('diff', '-u', $expected, $actual);
            return;
        }
    }
    return 1 unless $testdata;

    # 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(my $etags, '<', $actual);
        while (<$etags>) {
            next if m/^N: /;
            # Some of the traversal tests creates packages that are
            # skipped; accept that in the output
            next if m/tainted/o && m/skipping/o;
            # Looks for "$code: $package[ $type]: $tag"
            if (not /^.: \S+(?: (?:changes|source|udeb))?: (\S+)/o) {
                msg_print(($testdata->{'todo'} eq 'yes')? 'TODO' : 'E');
                msg_print ": Invalid line:\n$_";
                $okay = 0;
                next;
            }
            my $tag = $1;
            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;
                # Warn only once about each "test-against" tag
                delete $test_against{$tag};
            }
            delete $test_for{$tag};
        }
        close($etags);
        if (%test_for) {
            if ($origexp && $origexp ne $expected) {
                # Test has been calibrated, check if some of the
                # "Test-For" has been calibrated out.  (Happens with
                # binaries-hardening on some architectures).
                open(my $oe, '<', $expected);
                my %cp_tf = %test_for;
                while (<$oe>) {
                    next if m/^N: /;
                    # Some of the traversal tests creates packages that are
                    # skipped; accept that in the output
                    next if m/tainted/o && m/skipping/o;
                    if (not /^.: \S+(?: (?:changes|source|udeb))?: (\S+)/o) {
                        msg_print(
                            ($testdata->{'todo'} eq 'yes')? 'TODO' : 'E');
                        msg_print ": Invalid line:\n$_";
                        $okay = 0;
                        next;
                    }
                    print STDERR "N: Kept tag: $1\n";
                    delete $cp_tf{$1};
                }
                close($oe);
                # Remove tags that has been calibrated out.
                foreach my $tag (keys %cp_tf) {
                    delete $test_for{$tag};
                }
            }
            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');
        }
    }
}

# run_tests(&subref, @tests)
#
# Runs all the tests by passing them (one at the time) to &subref;
# note that it may do so in a threaded manner so &subref must be
# re-entrant. Blocks until all tests have been run.
#
# If &subref returns a truth value, the test is considered for passed
# (also used for skipped tests).  Otherwise it is a failure.
#
# Note, if "continue on error" is not set ($run_all_tests) a failing
# test will terminate the program.
#
sub run_tests{
    my ($code, @tsts) = @_;
    $q->enqueue(@tsts);
    for (my $i = 0; $i < $JOBS; $i++) {
        threads->create(
            sub {
                while (my $t = $q->dequeue_nb()) {
                    my $okay = eval { $code->($t); };
                    if (!$okay || $@) {
                        if (my $err = $@) {
                            msg_print "FAILED\n";
                            print STDERR "$err\n";
                        }
                        exit 1 unless $run_all_tests;
                        my $name = $t;
                        if (ref($t) eq 'HASH' && exists $t->{'testname'}) {
                            $name = $t->{'testname'};
                        }
                        if (1) {
                            lock($status);
                            $status ||= 1;
                            push(@{$failed}, $name);
                        }
                    }
                }
            }); # treads->create( sub { ...
    } # for loop

    # wait for the results;
    for my $thr (threads->list()) {
        $thr->join();
        if ($thr->error){
            # This should not happen, but if a thread terminate
            # badly make sure we do not return success.
            lock($status);
            $status = 1;
        }
    }

    return;
}

sub dump_log{
    my ($pkg, $logf) = @_;
    no autodie qw(open);
    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 check_test_is_sane {
    my ($dir, $data) = @_;

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

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

    $data->{source} ||= $data->{testname};
    $data->{type} ||= 'native';
    $data->{date} ||= $DATE;
    $data->{distribution} ||= 'unstable';
    $data->{description} ||= 'No Description Available';
    $data->{author}||= 'Debian Lintian Maintainers <lintian-maint@debian.org>';
    $data->{architecture} ||= 'all';
    $data->{profile} ||= 'debian';
    $data->{section} ||= 'devel';
    $data->{'standards_version'} ||= $STANDARDS_VERSION;
    $data->{sort} ||= 'yes';
    $data->{sort} = parse_boolean($data->{sort});
    $data->{'output-format'} ||= 'EWI';

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

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

    # 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
    # FIXME: deal with wildcards correctly.
    if (none { $data->{architecture} =~ m/\b$_\b/ } @architectures) {
        return 0;
    }

    return 1;
}

sub skip_test {
    my ($suite, $testname, $reason) = @_;
    msg_print "Skipped $testname.\n";
    if (1) {
        lock($skipped);
        if (!exists($skipped->{$suite})) {
            $skipped->{$suite} = shared_clone({});
        }
        $skipped->{$suite}->{$testname} = $reason;
    }
    return 1;
}

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

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

sub _flush {
    my ($thrs, $id, $length) = @_;
    print(' 'x$length,"\r");
    while (my $m = shift @{$thrs->{$id}}) {
        print $m;
    }
    print "\n";
    delete $thrs->{$id};
    return;
}

sub msg_queue_handler {
    # if _msg_qh fails
    eval {_msg_qh();};
    die "Error (msg_queue_handler): $@\n" if $@;
    die "_msg_qh returned!?\n";
}

sub _msg_qh {
    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) {
                _flush(\%thrs, $tid, $length);
            }
            $length = 0;
        } else {
            if (!exists($msg->{'msg'}) && exists($thrs{$id})) {
                _flush(\%thrs, $id, $length);
                $length = 0;
            } 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
                if ($flush) {
                    _flush(\%thrs, $id, $length);
                    $length = 0;
                }
            }
        }

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

            push @output, $p;
        }
        my $output = join(' || ', @output);
        # Only use \r (etc.) if the output seems to be a terminal
        # - This is to make build logs more readable.
        printf "%-${length}s\r", $output if $output_is_tty;
        $length = length($output);
    }
    # This should not be reachable, but perlcritic doesn't know that.
    return;
}

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