#!/usr/bin/perl

# Copyright © 1998 Richard Braakman
# Copyright © 2008 Frank Lichtenheld
# Copyright © 2008, 2009 Russ Allbery
# Copyright © 2014 Niels Thykier
# Copyright © 2018 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 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 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 strict;
use warnings;
use autodie;
use v5.10;

use Capture::Tiny qw(capture);
use Cwd;
use File::Basename;
use File::Path qw(make_path);
use File::Spec::Functions qw(abs2rel rel2abs splitpath splitdir);
use File::stat;
use Getopt::Long;
use List::MoreUtils qw(any uniq);
use List::Util qw(max);
use IO::Async::Function;
use IO::Async::Loop;
use Path::Tiny;
use TAP::Formatter::Console;
use TAP::Formatter::File;
use TAP::Harness;
use TAP::Parser::Aggregator;
use Term::ANSIColor;
use Try::Tiny;

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

    # TODO: MAKEFLAGS - some of the tests don't cope too well with it
    for my $var (keys %ENV) {
        delete $ENV{$var} unless exists $WHITELIST{$var};
    }

    # Ubuntu auto-builders run pkg-mangle which messes up test packages
    $ENV{'NO_PKG_MANGLE'} = 'true'
      unless exists($ENV{'NO_PKG_MANGLE'});

    $ENV{'LINTIAN_TEST_INSTALLED'} = 'no'
      unless exists $ENV{'LINTIAN_TEST_INSTALLED'};

    my $cwd = Cwd::getcwd();

    if ($ENV{'LINTIAN_TEST_INSTALLED'} eq 'yes') {
        $ENV{'LINTIAN_ROOT'} = '/usr/share/lintian';
        $ENV{'LINTIAN_FRONTEND'} = '/usr/bin/lintian';
    } else {
        $ENV{'LINTIAN_ROOT'} = $cwd;
        $ENV{'LINTIAN_FRONTEND'} = "$cwd/frontend/lintian";
    }

    $ENV{'LINTIAN_DPLINT_FRONTEND'}= "$ENV{'LINTIAN_ROOT'}/frontend/dplint";

    $ENV{'LINTIAN_TEST_ROOT'} = $cwd;
}

use lib "$ENV{'LINTIAN_TEST_ROOT'}/lib";

use Lintian::Internal::FrontendUtil qw(default_parallel);

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::Prepare qw(logged_prepare);
use Test::Lintian::Run qw(logged_runner);
use Test::ScriptAge qw(perl_modification_epoch our_modification_epoch);

use constant SPACE => q{ };
use constant INDENT => q{    };
use constant NEWLINE => qq{\n};
use constant EMPTY => q{};
use constant YES => q{yes};
use constant NO => q{no};

# display output immediately
STDOUT->autoflush;

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

Getopt::Long::Configure('bundling');
unless (
    Getopt::Long::GetOptions(
        '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('Please use -h for usage information.')
  if @ARGV > 1;

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

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

# check test set directory
die "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 "Test work directory $outpath is not a directory"
  unless -d $outpath;

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

my $ACTIVE_JOBS = 0;

my $output_is_tty = -t STDOUT;

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

my $string = capture {
    my @command = ($ENV{'LINTIAN_FRONTEND'}, '--version');
    system(@command) == 0
      or die "system @command failed: $?";
};
chomp $string;
my ($version) = $string =~ qr/^\S+\s+v(.+)$/;
die 'Cannot get Lintian version' unless length $version;
say "Version under test is $version.";

say 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 .= ',' . $coverage if $coverage ne '';
    $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"), and -1 if option was not specified at all
$numjobs = default_parallel() if $numjobs <= 0;
say "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/bin";
if (-d $helperpath) {
    my $helpers = rel2abs($helperpath)// die("Cannot resolve $helperpath: $!");
    $ENV{'PATH'} = "$helpers:$ENV{'PATH'}";
}

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

# get latest policy version and date
($ENV{'POLICY_VERSION'}, $ENV{'POLICY_EPOCH'}) = get_latest_policy();
say "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
"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
  = ('t/bin', 't/runners', 't/templates', 't/skeletons', 't/whitelists');
my @harnessfiles
  = map { File::Find::Rule->file->in("$ENV{'LINTIAN_TEST_ROOT'}/$_") }
  @harnessparts;
my $harness_files_epoch
  = max(map { -e $_ ? stat($_)->mtime : time } @harnessfiles);
$ENV{'HARNESS_EPOCH'}
  = max(our_modification_epoch, perl_modification_epoch, $harness_files_epoch);
say 'Harness modified on '. rfc822date($ENV{'HARNESS_EPOCH'});

say EMPTY;

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

say EMPTY;

my $status = 0;

# tests that were skipped and why
my %skipped;
# tests that failed
my @failed;

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

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

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

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

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

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

# remove any duplicates
@runscripts = uniq @runscripts;

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

say 'Running selected and required Perl test scripts.';
say EMPTY;

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

unless ($aggregator->all_passed || $keep_going) {
    $aggregator->stop;
    $formatter->summary($aggregator);
    exit 1;
}

say EMPTY;

# find test paths
my @testpaths = find_selected_lintian_testpaths($testset, $onlyrun);

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

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

# add the scripts in generated tests to be run
my @workscripts
  = map { File::Find::Rule->file->name('*.t')->in($_) } @workpaths;

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

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

say EMPTY;

$status = 1
  unless $aggregator->all_passed;

if (-t STDOUT && !$unattended) {
    my @failed = $aggregator->failed;
    say 'Offering to re-calibrate the tags expected in tests with errors.'
      if @failed;

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

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

        # only offer when matching tags
        next
          unless $testcase->{match_strategy} eq 'tags';

        my $diffpath = "$workpath/tagdiff";

        my $relative = abs2rel($workpath, $outpath);
        my $testpath = abs2rel(rel2abs($relative, $testset));
        my $tagspath = "$testpath/tags";

        if (-r $diffpath) {

            say EMPTY;

            print colored($testpath, 'bold white on_blue')
              . '  >>>  Fix (y/n/q)? ';

            my $decision = <STDIN>;
            chomp $decision;
            last if $decision eq 'q';
            next unless $decision eq 'y';

            # create tags if needed; helps when writing new tests
            path($tagspath)->touch
              unless -e $tagspath;

            die "Cannot run tagadjust for $testpath"
              if system('tagadjust', '-i', $diffpath, $tagspath);

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

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

exit $status;

# program is done

sub print_test_summary {

    if (%skipped) {
        print "\nSkipped/disabled tests:\n";
        for my $label (sort keys %skipped) {
            my $reason = $skipped{$label};
            print "    $label: $reason\n";
        }
    }
    if (my $number = @failed) {
        print "\nFailed tests ($number)\n";
        for my $test (@failed) {
            print "    $test\n";
        }
    }

    return;
}

sub usage {
    print <<"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 't/bin/build-test-packages'.
END
    return;
}

sub quick_hint {
    my ($selection) = @_;
    print <<"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
    return;
}

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