#!/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 v5.20;
use warnings;
use utf8;
use autodie;

use Capture::Tiny qw(capture_merged);
use Cwd;
use File::Copy;
use File::Find::Rule;
use File::stat;
use Getopt::Long;
use IO::Async::Function;
use IO::Async::Loop;
use List::Compare;
use Path::Tiny;
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(
      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'});

    my $cwd = Cwd::getcwd();
    $ENV{'LINTIAN_ROOT'} = $cwd;
    $ENV{'LINTIAN_TEST_ROOT'} = $cwd;
}

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

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

use Test::Lintian::Build qw(build_subject);
use Test::Lintian::ConfigFile qw(read_config);
use Test::Lintian::Helper
  qw(rfc822date cache_dpkg_architecture_values get_latest_policy get_recommended_debhelper_version);
use Test::Lintian::Hooks qw(run_lintian sed_hook sort_lines calibrate);
use Test::Lintian::Prepare qw(prepare);

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

# options
my $debug;
my $dump_logs = 1;
my $force_rebuild;
my $numjobs = -1;
my $outpath;
my $verbose = 0;

Getopt::Long::Configure('bundling');
unless (
    Getopt::Long::GetOptions(
        'B|force-rebuild'  => \$force_rebuild,
        'd|debug+'         => \$debug,
        'j|jobs:i'         => \$numjobs,
        'L|dump-logs!'     => \$dump_logs,
        '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 = path($testset)->absolute->stringify;

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

# create test work directory unless it exists
path($outpath)->mkpath
  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 = path($outpath)->relative->stringify;

say EMPTY;

# 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 = path($helperpath)->absolute->stringify
      // 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.";

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;

# find spec paths
my @descfiles
  = sort File::Find::Rule->file()->name('fill-values')->in("$testset/tags");

my @specpaths = map { path($_)->parent->absolute->stringify } @descfiles;

# prepare output directories
say 'Preparing the sources for '. scalar @specpaths. ' test packages.'
  if @specpaths;

my @prepqueue = map { path($_)->relative->stringify } @specpaths;

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

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

my @relative = map { path($_)->parent->relative($testset) } @specpaths;
my @sourcepaths = map {$_->absolute($sourceroot)->stringify } @relative;
my @buildpaths = map {$_->absolute($buildroot)->stringify } @relative;

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

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

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

$ENV{PERL_PATH_TINY_NO_FLOCK} =1;

my $prepare = IO::Async::Function->new(
    code => sub {
        my ($specpath) = @_;

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

        # calculate destination
        my $relative = path($specpath)->parent->relative($testset);
        my $sourcepath = $relative->absolute($sourceroot)->stringify;
        my $buildpath = $relative->absolute($buildroot)->relative->stringify;

        my $error;

        # capture output
        my $log = capture_merged {

            try {

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

                # prepare
                prepare($specpath, $sourcepath, $testset, $force_rebuild);

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

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

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

        return $specpath;
    },
    max_workers => $numjobs,
    max_worker_calls => 1,
);

my $loop = IO::Async::Loop->new;
$loop->add($prepare);

$SIG{INT} = sub { $prepare->stop; die "Caught a sigint $!" };
my @preptasks = map {$prepare->call(args => [$_])} sort @prepqueue;

my $allprepared = Future->wait_all(@preptasks);

$loop->await($allprepared);

my @failedprep = $allprepared->failed_futures;
if (@failedprep) {
    say EMPTY;
    say 'Failed preparation tasks:';
    say NEWLINE . $_->failure for @failedprep;
    exit 1;
} else {
    say 'Package sources are ready.';
}

say EMPTY;

my $build = IO::Async::Function->new(
    code => sub {
        my ($specpath, $position, $total) = @_;

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

        # many tests create files via debian/rules
        umask(022);

        # get destination
        my $relative = path($specpath)->parent->relative($testset);
        my $sourcepath = $relative->absolute($sourceroot)->relative->stringify;
        my $buildpath = $relative->absolute($buildroot)->relative->stringify;

        my $sha1sums
          = qx{cd $sourcepath; find . -type f -print0 | sort -z | xargs -0 sha1sum};

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

            # only rebuild if needed
            return
              if $sha1sums eq $previous;
        }

        $0 = "Lintian build test: $specpath [$position/$total]";
        say "Building in $buildpath [$position/$total]";

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

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

        my $error;

        my $log = capture_merged {

            try {
                # call runner
                build_subject($sourcepath, $buildpath);
            }catch {
                # catch any error
                $error = $_;
            };
        };

        # delete old runner log
        my $betterlogpath = "$buildpath/$files->{log}";
        unlink $betterlogpath if -f $betterlogpath;

       # move the early log for directory preparation to position of runner log
        my $earlylogpath = "$sourcepath.log";
        move($earlylogpath, $betterlogpath) if -f $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($sha1sums)
          unless length $error;

        # print log and die on error
        die(($log // EMPTY) . "Builder died for $buildpath: $error")
          if length $error;

        return $specpath;
    },
    max_workers => $numjobs,
    max_worker_calls => 1,
);

$loop->add($build);

$SIG{INT} = sub { $build->stop; die "Caught a sigint $!" };

my $counter;
my @buildtasks= map {$build->call(args => [$_, ++$counter, scalar @specpaths])}
  sort @specpaths;

my $allbuilt = Future->wait_all(@buildtasks);

$loop->await($allbuilt);

my @failedbuilds = $allbuilt->failed_futures;
if (@failedbuilds) {
    say EMPTY;
    say 'Failed build tasks:';
    say NEWLINE . $_->failure for @failedbuilds;
    exit 1;
} else {
    say 'All test packages are up to date.';
}

say EMPTY;

exit 0;

# program is done

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

    -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.
    -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:...>]
END
    return;
}

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