lintian/private/runtests

#!/usr/bin/perl

# Copyright (C) 1998 Richard Braakman
# Copyright (C) 2008 Frank Lichtenheld
# Copyright (C) 2008, 2009 Russ Allbery
# Copyright (C) 2014 Niels Thykier
# Copyright (C) 2020 Felix Lechner
#
# 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 https://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 test suite.  For detailed information on
# the test suite layout and naming conventions, see t/tests/README.
# For more information about running tests, see
# doc/tutorial/Lintian/Tutorial/TestSuite.pod
#

use v5.20;
use warnings;
use utf8;

use Const::Fast;
use Cwd qw(realpath);
use File::Basename qw(dirname);

# neither Path::This nor lib::relative are in Debian
use constant THISFILE => realpath __FILE__;
use constant THISDIR => dirname realpath __FILE__;

# use Lintian modules that belong to this program
use lib THISDIR . '/../lib';

use Capture::Tiny qw(capture_merged);
use Cwd qw(getcwd);
use File::Copy;
use File::Find::Rule;
use File::Path qw(make_path);
use File::Spec::Functions qw(abs2rel rel2abs splitpath splitdir);
use File::stat;
use Getopt::Long;
use IPC::Run3;
use List::Compare;
use List::SomeUtils qw(any uniq);
use List::Util qw(max);
use IO::Interactive qw(is_interactive);
use IO::Prompt::Tiny qw(prompt);
use MCE::Loop;
use Path::Tiny;
use Syntax::Keyword::Try;
use TAP::Formatter::Console;
use TAP::Formatter::File;
use TAP::Harness;
use TAP::Parser::Aggregator;
use Term::ANSIColor;
use Time::Duration;
use Time::Moment;
use Time::Piece;
use Unicode::UTF8 qw(encode_utf8 decode_utf8);

use Lintian::IPC::Run3 qw(safe_qx);

use Test::Lintian::Build qw(build_subject);
use Test::Lintian::ConfigFile qw(read_config);
use Test::Lintian::Filter
  qw(find_selected_scripts find_selected_lintian_testpaths);
use Test::Lintian::Helper
  qw(rfc822date cache_dpkg_architecture_values get_latest_policy get_recommended_debhelper_version);
use Test::Lintian::Hooks qw(sed_hook sort_lines calibrate);
use Test::Lintian::Prepare qw(filleval prepare);
use Test::Lintian::Run qw(logged_runner);
use Test::ScriptAge qw(perl_modification_epoch our_modification_epoch);

const my $EMPTY => q{};
const my $SPACE => q{ };
const my $INDENT => $SPACE x 4;
const my $NEWLINE => qq{\n};
const my $SLASH => q{/};
const my $COMMA => q{,};
const my $COLON => q{:};
const my $ARROW => q{>>>};
const my $YES => q{yes};
const my $NO => q{no};

const my $WIDELY_READABLE => oct(22);

# display output immediately
STDOUT->autoflush;

# something changes the default handler, see Bug#974575
$SIG{WINCH} = 'DEFAULT';

# see https://stackoverflow.com/a/60761593
$SIG{CHLD} ||= 'DEFAULT';
$SIG{HUP} ||= 'DEFAULT';

my $processing_start = Time::Moment->from_string(gmtime->datetime . 'Z');

# whitelist the environment we permit to avoid things that mess up
# tests, like CFLAGS, DH_OPTIONS, DH_COMPAT, DEB_HOST_ARCH
my %PRESERVE_ENV = map { $_ => 1 } qw(
  LINTIAN_TEST_INSTALLED
  PATH
  TMPDIR
);

my @disallowed = grep { !exists $PRESERVE_ENV{$_} } keys %ENV;

delete $ENV{$_} for @disallowed;

if (($ENV{LINTIAN_TEST_INSTALLED} // 'no') eq 'yes') {

    $ENV{LINTIAN_UNDER_TEST} = realpath('/usr/bin/lintian')
      // die encode_utf8('Lintian is not installed');

} else {
    $ENV{LINTIAN_UNDER_TEST} = realpath(THISDIR . '/../bin/lintian');
}

$ENV{LINTIAN_BASE}= realpath(dirname(dirname($ENV{LINTIAN_UNDER_TEST})))
  // die encode_utf8('Cannot resolve LINTIAN_BASE');

# options
my $coverage;
my $debug;
my $dump_logs = 1;
my $force_rebuild;
my $numjobs;
my $keep_going;
my $onlyrun;
my $outpath;
my $unattended;
my $verbose = 0;

Getopt::Long::Configure('bundling');
unless (
    Getopt::Long::GetOptions(
        'B|force-rebuild'  => \$force_rebuild,
        'c|coverage:s'     => \$coverage,
        'd|debug+'         => \$debug,
        'j|jobs:i'         => \$numjobs,
        'k|keep-going'     => \$keep_going,
        'L|dump-logs!'     => \$dump_logs,
        'o|onlyrun:s'      => \$onlyrun,
        'u|unattended'     => \$unattended,
        'v|verbose'        => \$verbose,
        'w|work-dir:s'     => \$outpath,
        'h|help'           => sub {usage(); exit;},
    )
) {
    usage();
    die;
}

# check number of arguments
die encode_utf8('Please use -h for usage information.')
  if @ARGV > 1;

# get arguments
my ($testset) = @ARGV;

# default test set
$testset ||= 't';

# check test set directory
die encode_utf8("Cannot find testset directory $testset")
  unless -d $testset;

# make sure testset is an absolute path
$testset = rel2abs($testset);

# calculate a default test work directory if none given
$outpath ||= dirname($testset) . '/debian/test-out';

# create test work directory unless it exists
make_path($outpath)
  unless -e $outpath;

# make sure test work path is a directory
die encode_utf8("Test work directory $outpath is not a directory")
  unless -d $outpath;

# make sure outpath is absolute
$outpath = rel2abs($outpath);

my $ACTIVE_JOBS = 0;

# get lintian modification date
my @lintianparts
  = ('checks', 'commands', 'data','bin', 'profiles', 'vendors', 'lib/Lintian');
my @lintianfiles
  = map { File::Find::Rule->file->in("$ENV{'LINTIAN_BASE'}/$_") }@lintianparts;
push(@lintianfiles, Cwd::realpath($ENV{'LINTIAN_UNDER_TEST'}));
$ENV{'LINTIAN_EPOCH'}
  = max(map { -e ? path($_)->stat->mtime : time } @lintianfiles);
say encode_utf8('Lintian modified on '. rfc822date($ENV{'LINTIAN_EPOCH'}));

my $lintian_error;
my $bytes = capture_merged {
    my @command = ($ENV{'LINTIAN_UNDER_TEST'}, '--version');
    system(@command) == 0
      or $lintian_error = "system @command failed: $?";
};
my $string = decode_utf8($bytes);
die encode_utf8($string . $lintian_error)
  if length $lintian_error;

chomp $string;
my ($version) = $string =~ qr/^\S+\s+v(.+)$/;
die encode_utf8('Cannot get Lintian version') unless length $version;
say encode_utf8("Version under test is $version.");

say encode_utf8($EMPTY);

# set environment for coverage
if (defined $coverage) {
    # 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 $args= '-MDevel::Cover=-silent,1,+ignore,^(.*/)?t/scripts/.+';
    $args .= ',+ignore,/usr/bin/.*,+ignore,(.*/)?Dpkg';
    $args .= ',-coverage,' . join(',-coverage,', @criteria);
    $args .= $COMMA . $coverage if $coverage ne $EMPTY;
    $ENV{'LINTIAN_COVERAGE'} = $args;

    $ENV{'HARNESS_PERL_SWITCHES'} //= $EMPTY;
    $ENV{'HARNESS_PERL_SWITCHES'} .= $SPACE . $args;
}

# Devel::Cover + one cover_db + multiple processes is a recipe
# for corruptions.  Force $numjobs to 1 if we are running under
# coverage.
$numjobs = 1 if exists $ENV{'LINTIAN_COVERAGE'};

# tie verbosity to debug
$verbose = 1 + $debug if $debug;

# can be 0 without value ("-j") or undef if option was not specified at all
$numjobs ||= default_parallel();
say encode_utf8("Running up to $numjobs tests concurrently")
  if $numjobs > 1 && $verbose >= 2;

$ENV{'DUMP_LOGS'} = $dump_logs//$NO ? $YES : $NO;

# Disable translation support in dpkg as it is a considerable
# unnecessary overhead.
$ENV{'DPKG_NLS'} = 0;

my $helperpath = "$testset/../private";
if (-d $helperpath) {
    my $helpers = rel2abs($helperpath)
      // die encode_utf8("Cannot resolve $helperpath: $!");
    $ENV{'PATH'} = "$helpers:$ENV{'PATH'}";
}

# get architecture
cache_dpkg_architecture_values();
say encode_utf8("Host architecture is $ENV{'DEB_HOST_ARCH'}.");

# get latest policy version and date
($ENV{'POLICY_VERSION'}, $ENV{'POLICY_EPOCH'}) = get_latest_policy();
say encode_utf8("Latest policy version is $ENV{'POLICY_VERSION'} from "
      . rfc822date($ENV{'POLICY_EPOCH'}));

# get current debhelper compat level; do not name DH_COMPAT; causes conflict
$ENV{'DEFAULT_DEBHELPER_COMPAT'} = get_recommended_debhelper_version();
say encode_utf8(
"Using compat level $ENV{'DEFAULT_DEBHELPER_COMPAT'} as a default for packages built with debhelper."
);

# get harness date, including templates, skeletons and whitelists
my @harnessparts
  = ('bin', 't/defaults', 't/templates', 't/skeletons', 't/whitelists');
my @harnessfiles
  = map { File::Find::Rule->file->in("$ENV{'LINTIAN_BASE'}/$_") }@harnessparts;
my $harness_files_epoch
  = max(map { -e ? path($_)->stat->mtime : time } @harnessfiles);
$ENV{'HARNESS_EPOCH'}
  = max(our_modification_epoch, perl_modification_epoch, $harness_files_epoch);
say encode_utf8('Harness modified on '. rfc822date($ENV{'HARNESS_EPOCH'}));

say encode_utf8($EMPTY);

# print environment
my @vars = sort keys %ENV;
say encode_utf8('Environment:') if @vars;
for my $var (@vars) { say encode_utf8($INDENT . "$var=$ENV{$var}") }

say encode_utf8($EMPTY);

my $status = 0;

my $formatter = TAP::Formatter::File->new(
    {
        errors => 1,
        jobs => $numjobs,
    }
);
$formatter = TAP::Formatter::Console->new(
    {
        errors => 1,
        jobs => $numjobs,
        color => 1,
    }
) if is_interactive;

my $harness = TAP::Harness->new(
    {
        formatter => $formatter,
        jobs => $numjobs,
        lib => ["$ENV{'LINTIAN_BASE'}/lib"],
    }
);

my $aggregator = TAP::Parser::Aggregator->new;
$aggregator->start;

my @runscripts;
my $allscripts_path = "$testset/scripts";

# add selected scripts
push(@runscripts, find_selected_scripts($allscripts_path, $onlyrun));

# always add internal harness tests
my @requiredscripts;
@requiredscripts
  = sort File::Find::Rule->file()->name('*.t')->in("$allscripts_path/harness")
  unless length $onlyrun;
push(@runscripts, @requiredscripts);

# remove any duplicates
@runscripts = uniq @runscripts;

# make all paths relative
@runscripts = map { abs2rel($_) } @runscripts;

say encode_utf8('Running selected and required Perl test scripts.');
say encode_utf8($EMPTY);

# run scripts through harness
$harness->aggregate_tests($aggregator, sort @runscripts);

if (@runscripts && !$aggregator->all_passed && !$keep_going) {
    $aggregator->stop;
    $formatter->summary($aggregator);
    exit 1;
}

say encode_utf8($EMPTY);

my @testpaths = find_selected_lintian_testpaths($testset, $onlyrun);

my $recipe_root = "$testset/recipes";

# find test paths
my @recipes = map { path($_)->relative($recipe_root)->stringify }@testpaths;

# prepare output directories
say encode_utf8(
    'Preparing the sources for '. scalar @recipes. ' test packages.')
  if @recipes;

# for filled templates
my $source_root = "$outpath/package-sources";

# for built test packages
my $build_root = "$outpath/packages";

# find build specifications
my @all_recipes = map { path($_)->parent->stringify }
  sort File::Find::Rule->relative->name('build-spec')->in($recipe_root);

my @source_paths
  = map { path($_)->absolute($source_root)->stringify } @all_recipes;
my @build_paths
  = map { path($_)->absolute($build_root)->stringify } @all_recipes;

# remove obsolete package sources
my @found_sources = map { path($_)->parent->absolute->stringify; }
  File::Find::Rule->file->name('fill-values')->in($source_root);
my $sourcelc = List::Compare->new(\@found_sources, \@source_paths);
my @obsolete_sources = $sourcelc->get_Lonly;
path($_)->remove_tree for @obsolete_sources;

# remove obsolete built packages
my @found_builds = map { path($_)->parent->absolute->stringify; }
  File::Find::Rule->file->name('source-files.sha1sums')->in($build_root);
my $packagelc= List::Compare->new(\@found_builds, \@build_paths);
my @obsolete_builds = $packagelc->get_Lonly;
path($_)->remove_tree for @obsolete_builds;

# remove empty directories
for my $folder (@obsolete_sources, @obsolete_builds) {
    my $candidate = path($folder)->parent;
    while ($candidate->exists && !$candidate->children) {
        rmdir $candidate->stringify;
        $candidate = $candidate->parent;
    }
}

$ENV{PERL_PATH_TINY_NO_FLOCK} =1;

$SIG{INT} = sub { MCE::Loop->finish; die encode_utf8("Caught a sigint $!") };
my $mce_loop = MCE::Loop->init(
    max_workers => $numjobs,
    chunk_size => 1,
    flush_stdout => 1,
    flush_stderr => 1,
);

my %failedprep = mce_loop {
    my ($mce, $chunk_ref, $chunk_id) = @_;

    prepare_build($mce, $_);
}
@recipes;

if (%failedprep) {
    say encode_utf8($EMPTY);
    say encode_utf8('Failed preparation tasks:');
    for my $recipe (sort keys %failedprep) {
        say encode_utf8($EMPTY);
        say encode_utf8($ARROW
              . $SPACE
              . path("$recipe_root/$recipe")->relative->stringify
              . $COLON);
        print encode_utf8($failedprep{$recipe});
    }

    MCE::Loop->finish;
    exit 1;

} else {
    say encode_utf8('Package sources are ready.');
}

say encode_utf8($EMPTY);

my %failedbuilds = mce_loop {
    my ($mce, $chunk_ref, $chunk_id) = @_;

    build_package($mce, $_, $chunk_id, scalar @recipes);
}
@recipes;

$SIG{INT} = 'DEFAULT';
MCE::Loop->finish;

if (%failedbuilds) {
    say encode_utf8($EMPTY);
    say encode_utf8('Failed build tasks:');
    for my $recipe (sort keys %failedbuilds) {
        say encode_utf8($EMPTY);
        say encode_utf8($ARROW
              . $SPACE
              . path("$recipe_root/$recipe")->relative->stringify
              . $COLON);
        print encode_utf8($failedbuilds{$recipe});
    }

    exit 1;
} else {
    say encode_utf8('All test packages are up to date.');
}

say encode_utf8($EMPTY);

my $build_end = Time::Moment->from_string(gmtime->datetime . 'Z');
my $build_duration = duration($processing_start->delta_seconds($build_end));
say encode_utf8("Building the test packages took $build_duration.");

say encode_utf8($EMPTY);

# for built test packages
my $buildroot = "$outpath/packages";

# for built test packages
my $evalroot = "$outpath/eval";

$SIG{INT} = sub { MCE::Loop->finish; die encode_utf8("Caught a sigint $!") };

mce_loop {
    my ($mce, $chunk_ref, $chunk_id) = @_;

    prepare_test($mce, $_);
}
sort @testpaths;

MCE::Loop->finish;

$SIG{INT} = 'DEFAULT';

# remap paths from testset to outpath to get work directories
my @workpaths
  = map { rel2abs(abs2rel($_, "$testset/recipes"), "$outpath/eval") }
  @testpaths;

# if ($platforms ne 'any') {
#     my @wildcards = split(/$SPACE/, $platforms);
#     my @matches= map {
#         decode_utf8(qx{dpkg-architecture -a $ENV{'DEB_HOST_ARCH'} -i $_; echo -n \$?})
#     } @wildcards;
#     unless (any { $_ == 0 } @matches) {
#         say encode_utf8('Architecture mismatch');
#         return;
#     }
# }

# make all paths relative to current directory
@workpaths = map { path($_)->relative } @workpaths;

# add the scripts in generated tests to be run
my @workscripts;
for my $path (@workpaths) {

    my @runners = File::Find::Rule->file->name('*.t')->in($path);

    die encode_utf8("No runner in $path")
      unless scalar @runners;
    die encode_utf8("More than one runner in $path")
      if scalar @runners > 1;

    push(@workscripts, @runners);
}

# run scripts through harness
$harness->aggregate_tests($aggregator, sort @workscripts);

$aggregator->stop;
$formatter->summary($aggregator);

say encode_utf8($EMPTY);

my $test_end = Time::Moment->from_string(gmtime->datetime . 'Z');
my $test_duration = duration($processing_start->delta_seconds($test_end));
say encode_utf8("The test suite ran for $test_duration.");

$status = 1
  unless $aggregator->all_passed;

if (is_interactive && !$unattended) {
    my @failed = $aggregator->failed;
    say encode_utf8(
        'Offering to re-calibrate the hints expected in tests that failed.')
      if @failed;

    my $accept_all;

    for my $scriptpath (@failed) {
        my $workpath = dirname($scriptpath);

        my $descpath = "$workpath/desc";
        my $testcase = read_config($descpath);

        my $relative = abs2rel($workpath, $evalroot);
        my $testpath = abs2rel(rel2abs($relative, "$testset/recipes"));

        say encode_utf8($EMPTY);
        say encode_utf8(
            'Failed test: ' . colored($testpath, 'bold white on_blue'));

        my $match_strategy = $testcase->unfolded_value('Match-Strategy');

        if ($match_strategy eq 'hints') {

            my $diffpath = "$workpath/hintdiff";
            next
              unless -r $diffpath;

            my $diff = path($diffpath)->slurp_utf8;
            print encode_utf8($diff);

        } elsif ($match_strategy eq 'literal') {

            my $actualpath = "$workpath/literal.actual.parsed";
            next
              unless -r $actualpath;
            my @command
              = ('diff', '-uN', "$testpath/eval/literal", $actualpath);
            say encode_utf8(join($SPACE, @command));
            system(@command);

        } else {
            say encode_utf8(
"Do not know how to fix tests using matching strategy $match_strategy."
            );
            next;
        }

        unless ($accept_all) {

            my $decision_bytes = prompt(
                encode_utf8(
'>>>  Fix test (y), accept all (a), do not fix (n), quit (q/default)?'
                )
            );
            my $decision = decode_utf8($decision_bytes);

            last
              if $decision eq 'q' || $decision eq $EMPTY;

            next
              unless $decision eq 'y' || $decision eq 'a';

            $accept_all = 1
              if $decision eq 'a';
        }

        if ($match_strategy eq 'hints') {

            # create hints if needed; helps when writing new tests
            my $hintspath = "$testpath/eval/hints";
            path($hintspath)->touch
              unless -e $hintspath;

            my $diffpath = "$workpath/hintdiff";
            next
              unless -r $diffpath;

            my @adjustargs = ($diffpath, $hintspath);
            unshift(@adjustargs, '-i')
              unless $accept_all;

            die encode_utf8("Cannot run hintadjust for $testpath")
              if system('hintadjust', @adjustargs);

            # also copy the new hints to workpath; no need to rebuild
            die encode_utf8("Cannot copy updated hints to $workpath")
              if system('cp', $hintspath, "$workpath/hints");

        } elsif ($match_strategy eq 'literal') {

            my $actualpath = "$workpath/literal.actual.parsed";
            next
              unless -r $actualpath;

            die encode_utf8(
                "Cannot copy to accept literal output for $testpath")
              if system('cp', $actualpath, "$testpath/eval/literal");

        }
    }

    say encode_utf8($NEWLINE . 'Accepted all remaining hint changes.')
      if $accept_all;

} else {
    my @crashed = $aggregator->parse_errors;

    say encode_utf8('Showing full logs for tests with parse errors.')
      if @crashed;

    for my $absolutepath (@crashed) {

        my $scriptpath = abs2rel($absolutepath);
        my $workpath = dirname($scriptpath);
        my $logpath = "$workpath/log";

        next
          unless -e $logpath;

        say encode_utf8($EMPTY);
        say encode_utf8("Log for test $scriptpath:");

        my $log = path($logpath)->slurp_utf8;
        print encode_utf8($log);
    }
}

# give a hint if not enough tests were run
unless (scalar @runscripts - scalar @requiredscripts + scalar @workscripts
    || $onlyrun eq 'minimal:') {
    quick_hint($onlyrun);
    exit 1;
}

say encode_utf8($EMPTY);

exit $status;

# program is done

sub prepare_build {
    my ($mce, $recipe) = @_;

    # label process
    $0 = "Lintian prepare test: $recipe";

    # destination
    my $source_path = "$source_root/$recipe";

    my $error;

    # capture output
    my $log_bytes =capture_merged {

        try {

            # remove destination
            path($source_path)->remove_tree
              if -e $source_path;

            # prepare
            prepare("$recipe_root/$recipe/build-spec",
                $source_path, $testset, $force_rebuild);

        } catch {
            # catch any error
            $error = $@;
        }
    };

    my $log = decode_utf8($log_bytes);

    # save log;
    my $logfile = "$source_path.log";
    path($logfile)->spew_utf8($log) if $log;

    $mce->gather($recipe, $error)
      if length $error;

    return;
}

sub build_package {
    my ($mce, $recipe, $position, $total) = @_;

    # set a predictable locale
    $ENV{'LC_ALL'} = 'C';

    # many tests create files via debian/rules
    umask $WIDELY_READABLE;

    # get destination
    my $source_path = "$source_root/$recipe";
    my $build_path = "$build_root/$recipe";

    my $savedir = getcwd;
    chdir $source_path
      or die encode_utf8("Cannot change to directory $source_path");

    my $sha1sums_bytes;
    run3('find . -type f -print0 | sort -z | xargs -0 sha1sum',
        \undef, \$sha1sums_bytes);

    chdir $savedir
      or die encode_utf8("Cannot change to directory $savedir");

    my $sha1sums = decode_utf8($sha1sums_bytes);

    my $checksum_path = "$build_path/source-files.sha1sums";
    if (-r $checksum_path) {
        my $previous = path($checksum_path)->slurp_utf8;

        # only rebuild if needed
        # also need to look for build subject
        return
          if $sha1sums eq $previous;
    }

    $0 = "Lintian build test: $recipe [$position/$total]";
    say encode_utf8('Building in '
          . path($build_path)->relative->stringify
          . " [$position/$total]");

    path($build_path)->remove_tree
      if -e $build_path;
    path($build_path)->mkpath;

    # read dynamic file names
    my $runfiles = "$source_path/files";
    my $files = read_config($runfiles);

    my $error;

    my $log_bytes = capture_merged {

        try {
            # call runner
            build_subject($source_path, $build_path);

        } catch {
            # catch any error
            $error = $@;
        }
    };

    my $log = decode_utf8($log_bytes);

    # delete old runner log
    my $betterlogpath= $build_path . $SLASH . $files->unfolded_value('Log');
    if (-e $betterlogpath) {
        unlink $betterlogpath
          or die encode_utf8("Cannot unlink $betterlogpath");
    }

    # move the early log for directory preparation to position of runner log
    my $earlylogpath = "$source_path.log";
    move($earlylogpath, $betterlogpath) if -e $earlylogpath;

    # append runner log to population log
    path($betterlogpath)->append_utf8($log) if length $log;

    # add error if there was one
    path($betterlogpath)->append_utf8($error) if length $error;

    path($checksum_path)->spew_utf8($sha1sums)
      unless length $error;

    $mce->gather(path($build_path)->relative->stringify, $error . $log)
      if length $error;

    return;
}

sub prepare_test {
    my ($mce, $specpath) = @_;

    # label process
    $0 = "Lintian prepare test: $specpath";

    # calculate destination
    my $relative = path($specpath)->relative("$testset/recipes");
    my $buildpath = $relative->absolute($buildroot)->stringify;
    my $evalpath = $relative->absolute($evalroot)->relative->stringify;

    my $error;

    # capture output
    my $log_bytes = capture_merged {

        try {

            # remove destination
            path($evalpath)->remove_tree
              if -e $evalpath;

            path($evalpath)->mkpath;

            # prepare
            filleval("$specpath/eval", $evalpath, $testset);

            my $traversal = Cwd::realpath("$buildpath/subject");

            if (length $traversal) {
                die encode_utf8("Cannot link to subject in $buildpath")
                  if system("cd $evalpath; ln -s $traversal subject");
            }

        }catch {
            # catch any error
            $error = $@;
        }
    };

    my $log = decode_utf8($log_bytes);

    # save log;
    my $logfile = "$evalpath/log";
    path($logfile)->spew_utf8($log) if $log;

    # print something if there was an error
    die encode_utf8(
        ($log // $EMPTY) . "Preparation failed for $specpath: $error")
      if $error;

    return $specpath;
}

=item default_parallel

=cut

# Return the default number of parallelization to be used
sub default_parallel {
    # check cpuinfo for the number of cores...
    my $cpus = decode_utf8(safe_qx('nproc'));
    if ($cpus =~ m/^\d+$/) {
        # Running up to twice the number of cores usually gets the most out
        # of the CPUs and disks but it might be too aggressive to be the
        # default for -j. Only use <cores>+1 then.
        return $cpus + 1;
    }

    # No decent number of jobs? Just use 2 as a default
    return 2;
}

sub usage {
    my $message =<<"END";
Usage: $0 [options] [-j [<jobs>]] <testset-directory>

    --onlyrun   Select only some tests for a quick check
    --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 option --onlyrun  causes runtests to only run tests that match
    the particular selection.  This parameter can be a list of selectors:
    what:<which>[,<what:...>]

      * test:<testname>
        - Run the named test. Please note that testnames may not be
          unique, so it may run more than one test.
      * script:(<script-name> || <dir-in-scripts-suite>)
        - Run the named code quality script or all in the named directory.
          E.g. "01-critic" will run all tests in "t/scripts/01-critic/".
      * check:<check-name>
        - Run all tests related to the given check.
      * suite:<suite>
        - Run all tests in the named suite.
      * tag:<tag-name>
        - Run any test that lists <tag-name> in "Test-For" or
          "Test-Against".

Test artifacts are cached in --work-dir [default: debian/test-out] and
will generally be reused to save time. To recreate the test packages,
run 'private/build-test-packages'.
END

    print encode_utf8($message);

    return;
}

sub quick_hint {
    my ($selection) = @_;

    my $message =<<"END";

No tests were selected by your filter:

    $selection

To select your tests, please use an appropriate argument with a
selector like:

    'suite:', 'test:', 'check:', 'tag:', or 'script:'

You can also use 'minimal:', which runs only the tests that cannot
be turned off, such as the internal tests for the harness.
END

    print encode_utf8($message);

    return;
}

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