#!/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 Cwd();

use threads;
use Thread::Queue;

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

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

BEGIN {
    my $LINTIAN_ROOT = $ENV{'LINTIAN_ROOT'};
    if (not $LINTIAN_ROOT) {
        require Cwd;
        $ENV{'LINTIAN_ROOT'} = $LINTIAN_ROOT = Cwd::cwd();
    }
    delete $ENV{'LINTIAN_CFG'};
    delete $ENV{'LINTIAN_LAB'};
    delete $ENV{'LINTIAN_DIST'};
    $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;

# --- 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';
if (`dpkg-source --help` =~ m,\s--commit\s,) {
    # dpkg (>= 1.16.1) doesn't automatically create patches anymore, unless
    # explicitly asked to do so:
    $DPKG_BUILDPACKAGE .= ' --source-option=--auto-commit';
}
our $STANDARDS_VERSION = '3.9.3';
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;

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

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
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 %suites = ();

my @tests;
my $prev;

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

if ($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 (! $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) {
        @tests = read_dpkg_control($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_dpkg_control($_) } sort(<$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;

foreach my $tsi (['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', @_) } ]) {
    my ($tdir, $globstr, $runner) = @$tsi;
    $prev = $prev || scalar(@tests);
    @tests = ();
    if ($singletest) {
        my $test = $singletest;
        if (-d "$TESTSET/$tdir/$test") {
            @tests = read_dpkg_control("$TESTSET/$tdir/$test/desc");
        } elsif (-f "$LINTIAN_ROOT/checks/$singletest.desc"){
            @tests = map { read_dpkg_control($_) } 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_dpkg_control($_) } 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";
    }
}
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, $glob) = @_;
    return generic_find_test_for_tag($tag, $glob, sub {
        my ($tag, $desc) = @_;
        my ($data) = read_dpkg_control($desc);
        my $tagnames = $data->{'test-for'}//'';
        $tagnames .= ' ' . $data->{'test-against'} if $data->{'test-against'};
        my %table = map { $_ => 1 } split(m/\s++/o, $tagnames);
        return $data if $table{$tag};
        return 0;
    });
}


sub copy_template_dir {
    my ($skel, $tsrc, $targetdir, $exskel, $extsrc) = @_;
    my @exs = ();
    my @ext = ();
    @exs = @$exskel if $exskel;
    @ext = @$extsrc if $extsrc;
    runsystem('rsync', '-rpc', "$skel/", "$targetdir/", @exs);
    runsystem('rsync', '-rpc', "$tsrc/", "$targetdir/", @ext)
        if -d "$tsrc/";
}

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

    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/$suite/$testdata->{testname}";
    my $targetdir = "$rundir/$pkgdir";
    my $tmpldir = "$TESTSET/templates/$suite/";

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

    if (-f "$origdir/skip") {
        msg_print "skipped.\n";
        return 1;
    }

    # 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};
    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);
        }
        runsystem("cd $rundir && ".
                  "tar czf ${pkg}_${orig_version}.orig.tar.gz $pkgdir");
    }
    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") {
        runsystem("echo >$targetdir/debian/watch");
    }
    if (-x "$origdir/pre_build") {
        msg_print 'running pre_build hook... ' if $VERBOSE;
        runsystem("$origdir/pre_build", $targetdir);
    }

    my $file = _builder_tests($testdata, "$rundir/$pkgdir", "$rundir/build.$pkg");

    run_lintian($testdata, $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";

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

sub _builder_tests {
    my ($testdata, $testdir, $log) = @_;
    my $pkg = $testdata->{srcpkg};
    msg_print 'building... ';
    my $res = system("cd $testdir && $DPKG_BUILDPACKAGE >$log 2>&1");
    if ($res){
        dump_log($pkg, $log) if $DUMP_LOGS;
        fail("cd $testdir && $DPKG_BUILDPACKAGE >$log 2>&1");
    }
    my $version = $testdata->{version};
    $version =~ s/^(\d+)://;

    my ($file) = glob("$testdir/../$pkg\_$version*.changes");
    return $file;
}

sub run_lintian {
    my ($testdata, $file, $out) = @_;
    msg_print 'testing... ';
    my $status = 0;
    # Quote (A test use -L <=, which blows up if we don't... plus it is safer that way)
    my @options = map { quotemeta $_ } split(' ', $testdata->{options}//'');
    my $cmd;
    my $ret;
    unshift(@options, '--allow-root', '--no-cfg');
    unshift(@options, '--profile', $testdata->{profile}) if $testdata->{profile};
    $cmd = "$LINTIAN " . join(' ', @options). " $file 2>&1";
    if (open my $in, '-|', $cmd) {
        my @data = <$in>;
        close $in;
        $status = ($? >> 8) & 255;
        unless ($status == 0 or $status == 1) {
            msg_print "FAILED\n";
            msg_print @data;
            fail "$LINTIAN @options $file exited with status $status";
        } else {
            @data = sort @data if $testdata->{sort};
            open my $fd, '>', $out or fail "opening $out: $!";
            print $fd $_ for @data;
            close $fd or fail "closing $out: $!";
        }
    } else {
        fail ("pipe+fork: $!");
    }
    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) = @_;

    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 $test = $testdata->{srcpkg};
    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.
        @files = grep { !/\.(?:desc|tags)$/o } glob "$testdir/$test.*";
        runsystem('cp', '-f', @files, "$RUNDIR/");
        $file = "$RUNDIR/${test}.changes";
        fill_in_tmpl($file, $testdata);
    }

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

    return _check_result($testdata, "$testdir/$test.tags", "$RUNDIR/tags.changes-$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_find_test_for_tag($tag, $globstr[, $tcode])
#
# Looks for $tag in all files returned by using glob on $globstr.
# $tcode is called for each file with $tag as first argument and the filename
# as second argument.  $tcode is expected to return a truth value that if the
# test should be run.  If $tcode returns something that is not just a raw
# truth value (e.g. a list ref), this will be taken as the "test", otherwise
# this sub will attempt to guess the test name from the file.
#
# If $tcode is omitted, \&is_tag_in_file will be used.
#
# Returns a list of values returned by $tcode or guessed test names (as per
# above)
sub generic_find_test_for_tag {
    my ($tag, $globstr, $tcode) = @_;
    my @tests;
    $tcode = \&is_tag_in_file unless defined $tcode;
    for my $file (glob $globstr){
        my $res = $tcode->($tag, $file);
        my $testname;
        next unless $res;

        if ($res =~ m/^\d+$/o){
            # returned a truth value; use the regex to deduce the test name
            ($testname) = ($file =~ m,.*/([^/]+)[/\.]tags$,);
        } else {
            # The code returned the test name for us
            $testname = $res;
        }
        push @tests, $testname;
    }
    return @tests;
}

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

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

    my $test = $testdata->{testname};

    msg_print "Running $test... ";

    my $testdir = "$TESTSET/$suite/$test";
    my $targetdir = "$RUNDIR/$test";
    my $tmpldir = "$TESTSET/templates/$suite/";
    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);

    my $skel = $testdata->{skeleton};

    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 = system("cd $targetdir && fakeroot make >../build.$test 2>&1");
    if ($res){
        dump_log($test, "$RUNDIR/build.$test") if $DUMP_LOGS;
        fail("cd $targetdir && fakeroot make >../build.$test 2>&1");
    }
    my @matches = glob "$targetdir/*.$ext";
    my $file = shift @matches;
    unless ( $file && -e $file ) {
        fail "$test did not produce any file matching \"$targetdir/*.$ext\" ($file)";
    }
    fail "$test produced more than one file matching \"$targetdir/*.$ext\"" if @matches;

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

sub _check_result {
    my ($testdata, $expected, $actual) = @_;
    # 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 or fail("opening: $actual");
        while (<$etags>) {
            next if m/^N: /;
            # Some of the traversal tests 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) {
            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');
        }
    }
}

sub is_tag_in_file {
    my ($tag, $file) = @_;
    my $res = 0;
    open my $tags, '<', $file or fail "Cannot open $file";
    while (my $line = <$tags>){
        next if $line =~ m/^N: /;
        next unless ($line =~ m/^.: \S+(?: (?:changes|source|udeb))?: (\S+)/);
        next unless $1 eq $tag;
        $res = 1;
        last;
    }
    close $tags;
    return $res;
}

# 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 ($@) {
                        msg_print "FAILED\n";
                        print STDERR "$@\n";
                    }
                    exit 1 unless $run_all_tests;
                    lock($status);
                    $status = 1;
                }
            }
        }); # 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;
        }
    }

}

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} && exists $data->{version}) {
        fail('Name or Version missing');
    }

    $data->{srcpkg} ||= $data->{testname};
    $data->{type} ||= 'native';
    $data->{date} ||= $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 _flush {
    my ($thrs, $id, $length) = @_;
    print (' 'x$length,"\r");
    while (my $m = shift @{$thrs->{$id}}) {
        print $m;
    }
    print "\n";
    delete $thrs->{$id};
}

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];
            $p =~ s/\s+$//;

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

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