diff options
Diffstat (limited to 'private/runtests')
| -rwxr-xr-x | private/runtests | 972 |
1 files changed, 972 insertions, 0 deletions
diff --git a/private/runtests b/private/runtests new file mode 100755 index 0000000..0b27fd7 --- /dev/null +++ b/private/runtests @@ -0,0 +1,972 @@ +#!/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 |