#!/usr/bin/perl

# Copyright © 1998 Richard Braakman
# Copyright © 2008 Frank Lichtenheld
# Copyright © 2008, 2009 Russ Allbery
# Copyright © 2014 Niels Thykier
#
# 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 Cwd();
use File::Spec::Functions qw(abs2rel rel2abs splitpath splitdir);
use Getopt::Long;
use IO::Async::Channel;
use IO::Async::Loop;
use IO::Async::Routine;
use Try::Tiny;

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

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

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

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

    $ENV{'LC_ALL'} = 'C';

    # Set standard umask because many of the test packages rely on this
    # when creating files from the debian/rules script.
    umask(022);
}

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

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

use Test::Lintian::ConfigFile qw(read_config);
use Test::Lintian::Filter qw(find_selected_lintian_testpaths);
use Test::Lintian::Helper
  qw(rfc822date get_host_architecture get_latest_policy get_recommended_debhelper_version);
use Test::Lintian::Prepare qw(logged_prepare);
use Test::Lintian::Run qw(logged_runner);
use Test::State;

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 $force_rebuild;
my $numjobs = -1;
my $keep_going;
my $verbose = 0;

Getopt::Long::Configure('bundling');
unless (
    Getopt::Long::GetOptions(
        'B'            => \$force_rebuild,
        'd|debug+'     => \$debug,
        'j|jobs:i'     => \$numjobs,
        'k|keep-going' => \$keep_going,
        'dump-logs!'   => \$dump_logs,
        'v|verbose'    => \$verbose,
        'coverage:s'   => \$coverage,
        'help|h'       => sub {usage(); exit;},
    )
) {
    usage();
    die;
}

# check number of arguments
die('Please use -h for usage information. Thank you!')
  if @ARGV < 2 || @ARGV > 3;

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

# check test set directory
die("Test set directory $testset not set") unless -d $testset;
$testset = rel2abs($testset) // die("Cannot find $testset: $!");

# check output directory
die("Test output directory $outpath not set") unless -d $outpath;
$outpath = rel2abs($outpath) // die("Cannot find $outpath: $!");

my @TESTS;
my $ACTIVE_JOBS = 0;

my ($tag, %suites);

$ENV{HARNESS_EPOCH} = (stat($0))[9];

my $output_is_tty = -t STDOUT;

our $IO_LOOP = IO::Async::Loop->new;

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

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

# get architecture
$ENV{'DEB_HOST_ARCH'} = get_host_architecture();
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.";

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
# - $suite => $testname => $reason
my %skipped;
# Tests that failed
my @failed;

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

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

@TESTS = map { read_desc("$_/desc") } @testpaths;

if ($onlyrun && $onlyrun =~ s/^tag://) {
    $tag = $onlyrun;
    # clear onlyrun to avoid find a "single" test.
    $onlyrun = '';
} elsif ($onlyrun && $onlyrun =~ 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.
    $onlyrun = '';
} else {
    # run / check all of them
    foreach my $s (SUITES) {
        $suites{$s} = 1;
    }
}

if (!$tag) {
    run_prove_tests();
}

if (@TESTS) {
    for (0..$numjobs-1) {
        create_child($IO_LOOP, \@TESTS)
          or last;
    }

    $IO_LOOP->run;
}

print_test_summary();

exit $status;

sub print_test_summary {
    if (!$tests_run) {
        if ($onlyrun) {
            print "W: No tests run, did you specify a valid test name?\n";
        } elsif ($tag) {
            print "I: No tests found for that tag.\n";
        } else {
            print
              "E: No tests run, did you specify a valid testset directory?\n";
        }
    } else {
        if (%skipped) {
            print "\nSkipped/disabled tests:\n";
            for my $suite (SUITES) {
                if (exists($skipped{$suite})) {
                    print "  [$suite]\n";
                    for my $testname (sort(keys(%{ $skipped{$suite} }))) {
                        my $reason = $skipped{$suite}{$testname};
                        print "    $testname: $reason\n";
                    }
                }
            }
        }
        if (my $number = @failed) {
            print "\nFailed tests ($number)\n";
            for my $test (@failed) {
                print "    $test\n";
            }
        }
    }
    return;
}

sub read_desc {
    my ($path) = @_;

    my $testcase = read_config($path);

    # needed for suite calculation
    my $depth = scalar splitdir((splitpath($testset))[1]);

    # calculate suite from path
    my $suite = (splitdir((splitpath($path))[1]))[$depth];

    # add suite to data
    $testcase->{suite} = $suite;

    my $defaults = read_config("$testset/defaults/desc");

    foreach my $key (keys %{$defaults}) {
        $testcase->{$key} = $defaults->{$key}
          unless exists $testcase->{$key};
    }

    return $testcase;
}

sub run_prove_tests {
    my @do_run;
    if ($onlyrun) {
        for my $part (split(m/,/, $onlyrun)) {
            my $script = "$testset/scripts/${part}.t";
            if (-f $script) {
                push(@do_run, $script);
            } elsif (-d "$testset/scripts/${part}") {
                push(@do_run, "$testset/scripts/${part}");
            }
        }
    } elsif ($suites{'scripts'}) {
        unless (-d "$testset/scripts") {
            die "cannot find $testset/scripts: $!";
        }
        @do_run = ("$testset/scripts");
    }
    if (@do_run) {
        my $jobs = $numjobs;
        # Devel::Cover + one cover_db + multiple processes is a recipe
        # for corruptions.  Force $jobs to 1 if we are running under
        # coverage.
        $jobs = 1 if $ENV{'LINTIAN_COVERAGE'};
        my @prove_cmd
          = ('prove', '-j', $jobs, '-r', '-I', "$ENV{LINTIAN_TEST_ROOT}/lib");

        print "Test scripts:\n";
        if (system(@prove_cmd, @do_run) != 0) {
            exit 1 unless $keep_going;
            push(@failed, "suite:scripts [Try: prove -lr -j$numjobs t]");
            $status = 1;
        }
        $tests_run++;

        print "\n";
    }
    return;
}

sub create_child {
    my ($loop, $tests) = @_;
    my ($child_in_ch, $child_out_ch, $routine);
    my $start_test = shift(@{$tests});

    # If there are no more tests, don't spawn a routine for it
    # Usually happens when only running a single thread.
    return if not defined($start_test);

    # files don't close properly when numjobs > 1, this is a kludge
    $ENV{PERL_PATH_TINY_NO_FLOCK} = 1;

    $child_in_ch = IO::Async::Channel->new;
    $child_out_ch  = IO::Async::Channel->new;

    $routine = IO::Async::Routine->new(
        channels_in  => [$child_in_ch],
        channels_out => [$child_out_ch],

        code => sub {
            $0 = 'Test worker - idle';
            while (my $testcase = $child_in_ch->recv) {
                my $state = Test::State->new($testcase, $child_out_ch);
                my $suite = $testcase->{'suite'};
                my $testname = $testcase->{testname};

                my $specpath = "$testset/$suite/$testname";
                my $runpath = "$outpath/$suite/$testname";

                $0 = "Test worker - processing ${suite}::${testname}";

                try {
                    logged_prepare($specpath, $runpath, $suite,
                        $testset,$force_rebuild);
                    logged_runner($state, $runpath, $outpath);
                }
                catch {
                    if (my $err = $_) {
                        $state->test_error($err);
                    }
                };

                $0 = 'Test worker - idle';

                #                my $testname = $ref->{'testname'};
                #                print STDERR "$child_no: $suite::$testname\n";
                # Can only send references
                #                $child_out_ch->send( $ref );
            }
            return;
        },

        on_finish => sub {
            $ACTIVE_JOBS--;
            if ($ACTIVE_JOBS < 1) {
                print "Stopping loop, no more active workers\n"
                  if $verbose >= 2;
                $loop->stop;
            }
            return;
        },
    );

    $loop->add($routine);
    $ACTIVE_JOBS++;
    $child_in_ch->send($start_test);

    $child_out_ch->configure(
        'on_recv' => sub {
            my (undef, $from_child) = @_;
            handle_msg_from_child($child_in_ch, $tests, @{$from_child});
            return;
        },
    );
    return 1;
}

my $partial_line = 0;  ## no critic (it is reachable)

sub handle_msg_from_child {
    my ($child_in_ch, $test_queue, $msg_type, $test_metadata, @payload) = @_;
    my $suite = $test_metadata->{'suite'};
    my $testname = $test_metadata->{'testname'};

    if ($verbose >= 3) {
        my @dmsg = map { $_ // '<undef>' } @payload;
        print
          "PROTO-MSG [DEBUG] ${msg_type} -- ${suite}::${testname} [@dmsg]\n";
    }

    if (   $msg_type eq 'pass'
        or $msg_type eq 'skip'
        or $msg_type eq 'fail'
        or $msg_type eq 'error'
        or $msg_type eq 'pass-todo') {
        my $is_problem = ($msg_type eq 'fail' or $msg_type eq 'error');
        my ($info_msg) = @payload;
        my ($test, $final_msg, $show_msg);

        if ($is_problem) {
            push(@failed, "${suite}::${testname}");
            if (not $keep_going) {
                # Empty the queue, so no further jobs are started
                $#{$test_queue} = -1;
            }
            $status = 1 if not $status;
        } elsif ($msg_type eq 'skip') {
            $skipped{$suite}{$testname} = $payload[0];
        }
        $final_msg = "${msg_type} ${suite}::${testname}";
        $final_msg .= ": ${info_msg}" if defined($info_msg);
        if (not $output_is_tty and not $verbose) {
            if ($msg_type eq 'pass') {
                $final_msg = '.';
            } elsif ($msg_type eq 'skip') {
                $final_msg = 'S';
            } elsif ($msg_type eq 'pass-todo') {
                $final_msg = 'T';
            } else {
                $show_msg = 1;
            }
        } else {
            $show_msg = 1;
        }
        if ($show_msg) {
            $final_msg .= "\n";
            print "\n" if $partial_line;
            $partial_line = 0;
        } else {
            $partial_line++;
            if ($partial_line > 79) {
                $final_msg .= "\n";
                $partial_line = 0;
            }
        }
        print $final_msg;

        $test = shift(@{$test_queue});

        $tests_run++;
        if (defined($test)) {
            $child_in_ch->send($test);
        } else {
            $child_in_ch->close;
        }
    } elsif ($msg_type eq 'diff-files') {
        my ($original, $actual) = @payload;
        print "\n" if $partial_line;
        $partial_line = 0;
        print "${suite}::${testname}: diff -u ${original} ${actual}\n";
        print safe_qx('diff', '-u', $original, $actual);
    } elsif ($msg_type eq 'dump-file') {
        my ($log_file) = @payload;
        my $prefix = "${suite}::${testname}: ";
        print "\n" if $partial_line;
        $partial_line = 0;
        handle_dump_log($prefix, $log_file);
    } elsif ($msg_type eq 'progress') {
        my ($new_phase) = @payload;
        print "${suite}::${testname} is now in phase: ${new_phase}\n"
          if $verbose;
    } elsif ($msg_type eq 'log-msg') {
        my ($verbosity, $msg) = @payload;
        if ($verbosity <= $verbose) {
            my $level = 'INFO';
            $level = 'DEBUG' if $verbosity > 1;
            print "INFO-MSG [$level] ${suite}::${testname}: $msg\n";
        }
    }
    return;
}

sub handle_dump_log{
    my ($prefix, $logf) = @_;
    no autodie qw(open);
    if (open(my $log, '<', $logf)){
        print "${prefix}---- START BUILD LOG\n";
        print "${prefix}$_" while (<$log>);
        print "${prefix}---- END BUILD LOG\n";
        close($log);
    } else {
        print "!!! Could not dump $logf: $!";
    }
    return 1;
}

sub usage {
    print <<"END";
Usage: $0 [options] [-j [<jobs>]] <testset-directory> <testing-directory> [<test-selection>]

    --coverage  Run Lintian under Devel::Cover (Warning: painfully slow)
    -d          Display additional debugging information
    --dump-logs Print build log to STDOUT, if a build fails.
    -j [<jobs>] Run up to <jobs> jobs in parallel.
                If -j is passed without specifying <jobs>, the number
                of jobs started is <nproc>+1.
    -k          Do not stop after one failed test
    -v          Be more verbose
    --help, -h  Print this help and exit

    The optional 3rd parameter causes runtests to only run tests that match
    the particular selection.  This parameter can be 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 <testing-directory> and will be reused if
deemed "up-to-date".  This cache can greatly reduce the run time of the
test suite.
END
    return;
}

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