summaryrefslogtreecommitdiffstats
path: root/lib/Test
diff options
context:
space:
mode:
Diffstat (limited to '')
-rw-r--r--lib/Test/Lintian.pm697
-rw-r--r--lib/Test/Lintian/Build.pm163
-rw-r--r--lib/Test/Lintian/ConfigFile.pm132
-rw-r--r--lib/Test/Lintian/Filter.pm378
-rw-r--r--lib/Test/Lintian/Helper.pm198
-rw-r--r--lib/Test/Lintian/Hooks.pm228
-rw-r--r--lib/Test/Lintian/Output/EWI.pm117
-rw-r--r--lib/Test/Lintian/Output/Universal.pm189
-rw-r--r--lib/Test/Lintian/Prepare.pm551
-rw-r--r--lib/Test/Lintian/Run.pm570
-rw-r--r--lib/Test/Lintian/Templates.pm348
-rw-r--r--lib/Test/ScriptAge.pm109
-rw-r--r--lib/Test/StagedFileProducer.pm314
13 files changed, 3994 insertions, 0 deletions
diff --git a/lib/Test/Lintian.pm b/lib/Test/Lintian.pm
new file mode 100644
index 0000000..4bcf72b
--- /dev/null
+++ b/lib/Test/Lintian.pm
@@ -0,0 +1,697 @@
+# Copyright (C) 1998 Richard Braakman
+# Copyright (C) 2012 Niels Thykier
+# Copyright (C) 2018 Chris Lamb <lamby@debian.org>
+#
+# 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.
+
+package Test::Lintian;
+
+=head1 NAME
+
+Test::Lintian -- Check Lintian files for issues
+
+=head1 SYNOPSIS
+
+ # file 1
+ use Test::Lintian;
+ use Test::More import => ['done_testing'];
+ test_load_profiles('some/path');
+
+ done_testing;
+
+ # file 2
+ use Test::Lintian;
+ use Test::More import => ['done_testing'];
+ load_profile_for_test('vendor/profile', 'some/path', '/usr/share/lintian');
+ test_check_desc('some/path/checks');
+ test_load_checks('some/path/checks');
+ test_tags_implemented('some/path/checks');
+
+ done_testing;
+
+=head1 DESCRIPTION
+
+A testing framework for testing various Lintian files for common
+errors.
+
+=cut
+
+use v5.20;
+use warnings;
+use utf8;
+
+my $CLASS = __PACKAGE__;
+my $PROFILE;
+our @EXPORT = qw(
+ load_profile_for_test
+
+ test_check_desc
+ test_load_checks
+ test_load_profiles
+
+ program_name_to_perl_paths
+);
+
+use parent 'Test::Builder::Module';
+
+use Cwd qw(realpath);
+use Const::Fast;
+use File::Basename qw(basename);
+use File::Find ();
+use List::SomeUtils qw{any};
+use Path::Tiny;
+use Syntax::Keyword::Try;
+use Unicode::UTF8 qw(valid_utf8 decode_utf8 encode_utf8);
+
+use Lintian::Spelling qw(check_spelling);
+use Lintian::Deb822;
+use Lintian::Profile;
+use Lintian::Tag;
+
+const my $EMPTY => q{};
+const my $COLON => q{:};
+const my $MAXIMUM_TAG_LENGTH => 68;
+
+my %visibilities = map { $_ => 1 } @Lintian::Tag::VISIBILITIES;
+my %check_types = map { $_ => 1 } qw(binary changes source udeb);
+my %known_html_tags = map { $_ => 1 } qw(a em i tt);
+
+# lazy-load this (so loading a profile can affect it)
+my %URLS;
+
+=head1 FUNCTIONS
+
+=over 4
+
+=item test_check_desc(OPTS, CHECKS...)
+
+Test check desc files (and the tags in them) for common errors.
+
+OPTS is a HASHREF containing key/value pairs, which are
+described below.
+
+CHECKS is a list of paths in which to check desc files. Any given
+element in CHECKS can be either a file or a dir. Files are assumed to
+be check desc file. Directories are searched and all I<.desc> files
+in those dirs are processed.
+
+As the number of tests depends on the number of tags in desc, it is
+difficult to "plan ahead" when using this test. It is therefore
+recommended to not specify a plan and use done_testing().
+
+This sub uses a Data file (see L</load_profile_for_test ([PROFNAME[, INC...]])>).
+
+OPTS may contain the following key/value pairs:
+
+=over 4
+
+=item filter
+
+If defined, it is a filter function that examines $_ (or its first
+argument) and returns a truth value if C<$_> should be considered or
+false otherwise. C<$_> will be the path to the current file (or dir)
+in question; it may be relative or absolute.
+
+NB: I<all> elements in CHECKS are subject to the filter.
+
+CAVEAT: If the filter rejects a directory, none of the files in it will be
+considered either. Even if the filter accepts a file, that file will
+only be processed if it has the proper extension (i.e. with I<.desc>).
+
+=item translation
+
+If defined and a truth value, the desc files are expected to contain
+translations. Otherwise, they must be regular checks.
+
+=back
+
+=cut
+
+sub test_check_desc {
+ my ($opts, @dirs) = @_;
+
+ my $builder = $CLASS->builder;
+ my $colldir = '/usr/share/lintian/collection';
+ my $find_opt = {'filter' => undef,};
+ my $tested = 0;
+
+ $find_opt->{'filter'} = $opts->{'filter'}
+ if exists $opts->{'filter'};
+
+ $opts //= {};
+
+ load_profile_for_test();
+
+ my @descs = map { _find_check($find_opt, $_) } @dirs;
+ foreach my $desc_file (@descs) {
+
+ my $bytes = path($desc_file)->slurp;
+ $builder->ok(valid_utf8($bytes),
+ "File $desc_file does not use a national encoding.");
+ next
+ unless valid_utf8($bytes);
+
+ my $deb822 = Lintian::Deb822->new;
+
+ my @sections;
+ try {
+ @sections = $deb822->read_file($desc_file);
+
+ } catch {
+ my $err = $@;
+ $err =~ s/ at .*? line \d+\s*\n//;
+ $builder->ok(0, "Cannot parse $desc_file");
+ $builder->diag("Error: $err");
+ next;
+ }
+
+ my ($header, @tagpara) = @sections;
+
+ my $content_type = 'Check';
+ my $cname = $header->value('Check-Script');
+ my $ctype = $header->value('Type');
+ my $i = 1; # paragraph counter.
+ $builder->ok(1, "Can parse check $desc_file");
+
+ $builder->isnt_eq($cname, $EMPTY,
+ "$content_type has a name ($desc_file)");
+
+ # From here on, we just use "$cname" as name of the check, so
+ # we don't need to choose been it and $tname.
+ $cname = '<missing>' if $cname eq $EMPTY;
+ $tested += 2;
+
+ if ($cname eq 'lintian') {
+ my $reason = 'check "lintian" does not have a type';
+ # skip these two tests for this special case...
+ $builder->skip("Special case, $reason");
+ $builder->skip("Special case, $reason");
+ } elsif ($builder->isnt_eq($ctype, $EMPTY, "$cname has a type")) {
+ my @bad;
+ # new lines are not allowed, map them to "\\n" for readability.
+ $ctype =~ s/\n/\\n/g;
+ foreach my $type (split /\s*+,\s*+/, $ctype) {
+ push @bad, $type unless exists $check_types{$type};
+ }
+ $builder->is_eq(join(', ', @bad),
+ $EMPTY,"The type of $cname is valid");
+ } else {
+ $builder->skip(
+ "Cannot check type of $cname is valid (field is empty/missing)"
+ );
+ }
+
+ for my $tpara (@tagpara) {
+
+ my $tag = $tpara->value('Tag');
+ my $visibility = $tpara->value('Severity');
+ my $explanation = $tpara->value('Explanation');
+
+ my (@htmltags, %seen);
+
+ $i++;
+
+ # Tag name
+ $builder->isnt_eq($tag, $EMPTY, "Tag in check $cname has a name")
+ or $builder->diag("$cname: Paragraph number $i\n");
+ $tag = '<N/A>' if $tag eq $EMPTY;
+ $builder->ok($tag =~ /^[\w0-9.+-]+$/, 'Tag has valid characters')
+ or $builder->diag("$cname: $tag\n");
+ $builder->cmp_ok(length $tag, '<=', $MAXIMUM_TAG_LENGTH,
+ 'Tag is not too long')
+ or $builder->diag("$cname: $tag\n");
+
+ # Visibility
+ $builder->ok($visibility && exists $visibilities{$visibility},
+ 'Tag has valid visibility')
+ or $builder->diag("$cname: $tag visibility: $visibility\n");
+
+ # Explanation
+ my $mistakes = 0;
+ my $handler = sub {
+ my ($incorrect, $correct) = @_;
+ $builder->diag(
+ "Spelling ($cname/$tag): $incorrect => $correct");
+ $mistakes++;
+ };
+ # FIXME: There are a couple of known false-positives that
+ # breaks the test.
+ # check_spelling($profile, $explanation, $handler);
+ $builder->is_eq($mistakes, 0,
+ "$content_type $cname: $tag has no spelling errors");
+
+ $builder->ok(
+ $explanation !~ /(?:^| )(?:[Ww]e|I)\b/,
+ 'Tag explanation does not speak of "I", or "we"'
+ )or $builder->diag("$content_type $cname: $tag\n");
+
+ $builder->ok(
+ $explanation !~ /(\S\w)\. [^ ]/
+ || $1 =~ /^\.[ge]$/, # for 'e.g.'/'i.e.'
+ 'Tag explanation uses two spaces after a full stop'
+ ) or $builder->diag("$content_type $cname: $tag\n");
+
+ $builder->ok($explanation !~ /(\S\w\. )/,
+ 'Tag explanation uses only two spaces after a full stop')
+ or $builder->diag("$content_type $cname: $tag ($1)\n");
+
+ $builder->ok(valid_utf8($explanation),
+ 'Tag explanation must be written in UTF-8')
+ or $builder->diag("$content_type $cname: $tag\n");
+
+ # Check the tag explanation for unescaped <> or for unknown tags
+ # (which probably indicate the same thing).
+ while ($explanation
+ =~ s{<([^\s>]+)(?:\s+href=\"[^\"]+\")?>.*?</\1>}{}s){
+ push @htmltags, $1;
+ }
+ @htmltags
+ = grep { !exists $known_html_tags{$_} && !$seen{$_}++ }@htmltags;
+ $builder->is_eq(join(', ', @htmltags),
+ $EMPTY, 'Tag explanation has no unknown html tags')
+ or $builder->diag("$content_type $cname: $tag\n");
+
+ $builder->ok($explanation !~ /[<>]/,
+ 'Tag explanation has no stray angle brackets')
+ or $builder->diag("$content_type $cname: $tag\n");
+
+ if ($tpara->declares('See-Also')) {
+
+ my @issues = map { _check_reference($_) }
+ $tpara->trimmed_list('See-Also', qr{ \s* , \s* }x);
+
+ my $text = join("\n\t", @issues);
+
+ $builder->ok(!@issues, 'Proper references are used')
+ or $builder->diag("$content_type $cname: $tag\n\t$text");
+ }
+ }
+ }
+
+ $builder->cmp_ok($tested, '>', 0, 'Tested at least one desc file')
+ if @descs;
+ return;
+}
+
+=item test_load_profiles(ROOT, INC...)
+
+Test that all profiles in I<ROOT/profiles> are loadable. INC will be
+the INC path used as include path for the profile.
+
+If INC is omitted, then the include path will consist of (ROOT,
+'/usr/share/lintian'). Otherwise, INC will be used as is (and should
+include ROOT).
+
+This sub will do one test per profile loaded.
+
+=cut
+
+sub test_load_profiles {
+ my ($dir, @inc) = @_;
+
+ my $builder = $CLASS->builder;
+ my $absdir = realpath $dir;
+ my $sre;
+ my %opt = ('no_chdir' => 1,);
+
+ if (not defined $absdir) {
+ die encode_utf8("$dir cannot be resolved: $!");
+ }
+
+ $absdir = "$absdir/profiles";
+ $sre = qr{\Q$absdir\E/};
+
+ @inc = ($absdir, '/usr/share/lintian') unless @inc;
+
+ $opt{'wanted'} = sub {
+ my $profname = $File::Find::name;
+
+ return
+ unless $profname =~ s/\.profile$//;
+ $profname =~ s/^$sre//;
+
+ my $profile = Lintian::Profile->new;
+
+ try {
+ $profile->load($profname, \@inc, 0);
+
+ } catch {
+ $builder->diag("Load error: $@\n");
+ $profile = 0;
+ }
+
+ $builder->ok($profile, "$profname is loadable.");
+ };
+
+ File::Find::find(\%opt, $absdir);
+ return;
+}
+
+=item test_load_checks(OPTS, DIR[, CHECKNAMES...])
+
+Test that the Perl module implementation of the checks can be loaded
+and has a run sub.
+
+OPTS is a HASHREF containing key/value pairs, which are
+described below.
+
+DIR is the directory where the checks can be found.
+
+CHECKNAMES is a list of check names. If CHECKNAMES is given, only the
+checks in this list will be processed. Otherwise, all the checks in
+DIR will be processed.
+
+For planning purposes, every check processed counts for 2 tests and
+the call itself does on additional check. So if CHECKNAMES contains
+10 elements, then 21 tests will be done (2 * 10 + 1). Filtered out
+checks will I<not> be counted.
+
+All data files created at compile time or in the file scope will be
+loaded immediately (instead of lazily as done during the regular
+runs). This is done to spot missing data files or typos in their
+names. Therefore, this sub will load a profile if one hasn't been
+loaded already. (see L</load_profile_for_test ([PROFNAME[,
+INC...]])>)
+
+OPTS may contain the following key/value pairs:
+
+=over 4
+
+=item filter
+
+If defined, it is a filter function that examines $_ (or its first
+argument) and returns a truth value if C<$_> should be considered or
+false otherwise. C<$_> will be the path to the current file (or dir)
+in question; it may be relative or absolute.
+
+NB: filter is I<not> used if CHECKNAMES is given.
+
+CAVEAT: If the filter rejects a directory, none of the files in it will be
+considered either. Even if the filter accepts a file, that file will
+only be processed if it has the proper extension (i.e. with I<.desc>).
+
+=back
+
+=cut
+
+sub test_load_checks {
+ my ($opts, $dir, @check_names) = @_;
+
+ my $builder = $CLASS->builder;
+
+ unless (@check_names) {
+ my $find_opt = {'want-check-name' => 1,};
+ $find_opt->{'filter'} = $opts->{'filter'} if exists $opts->{'filter'};
+ @check_names = _find_check($find_opt, $dir);
+ } else {
+ $builder->skip('Given an explicit list of checks');
+ }
+
+ $builder->skip('No desc files found')
+ unless @check_names;
+
+ my $profile = load_profile_for_test();
+
+ foreach my $check_name (@check_names) {
+
+ my $path = $profile->check_path_by_name->{$check_name};
+ try {
+ require $path;
+
+ } catch {
+ $builder->skip(
+"Cannot check if $check_name has entry points due to load error"
+ );
+ next;
+ }
+
+ $builder->ok(1, "Check $check_name can be loaded");
+
+ my $module = $profile->check_module_by_name->{$check_name};
+
+ $builder->diag(
+ "Warning: check $check_name uses old entry point ::run\n")
+ if $module->can('run') && !$module->DOES('Lintian::Check');
+
+ # setup and breakdown should only be used together with files
+ my $has_entrypoint = any { $module->can($_) }
+ qw(source binary udeb installable changes always files);
+
+ if (
+ !$builder->ok(
+ $has_entrypoint, "Check $check_name has entry point"
+ )
+ ){
+ $builder->diag("Expected package name is $module\n");
+ }
+ }
+ return;
+}
+
+=item load_profile_for_test ([PROFNAME[, INC...]])
+
+Load a Lintian::Profile and ensure Data files can be used. This is
+needed if the test needs to access a data file or if a special profile
+is needed for the test. It does I<not> test the profile for issues.
+
+PROFNAME is the name of the profile to load. It can be omitted, in
+which case the sub ensures that a profile has been loaded. If no
+profile has been loaded, 'debian/main' will be loaded.
+
+INC is a list of extra "include dirs" (or Lintian "roots") to be used
+for finding the profile. If not specified, it defaults to
+I<$ENV{'LINTIAN_BASE'}> and I</usr/share/lintian> (in order).
+INC is ignored if a profile has already been loaded.
+
+CAVEAT: Only one profile can be loaded in a given test. Once a
+profile has been loaded, it is not possible to replace it with another
+one. So if this is invoked multiple times, PROFNAME must be omitted
+or must match the name of the loaded profile.
+
+=cut
+
+sub load_profile_for_test {
+ my ($profname, @inc) = @_;
+
+ # We have loaded a profile and are not asked to
+ # load a specific one - then current one will do.
+ return $PROFILE
+ if $PROFILE and not $profname;
+
+ die encode_utf8("Cannot load two profiles.\n")
+ if $PROFILE and $PROFILE->name ne $profname;
+
+ # Already loaded? stop here
+ # We just need it for spell checking, so debian/main should
+ # do just fine...
+ return $PROFILE
+ if $PROFILE;
+
+ $profname ||= 'debian/main';
+
+ $PROFILE = Lintian::Profile->new;
+ $PROFILE->load($profname, [@inc, $ENV{'LINTIAN_BASE'}]);
+
+ $ENV{'LINTIAN_CONFIG_DIRS'} = join($COLON, @inc);
+
+ return $PROFILE;
+}
+
+sub _check_reference {
+ my ($see_also) = @_;
+
+ my @issues;
+
+ my @MARKDOWN_CAPABLE = (
+ $PROFILE->menu_policy,
+ $PROFILE->perl_policy,
+ $PROFILE->python_policy,
+ $PROFILE->java_policy,
+ $PROFILE->vim_policy,
+ $PROFILE->lintian_manual,
+ $PROFILE->developer_reference,
+ $PROFILE->policy_manual,
+ $PROFILE->debconf_specification,
+ $PROFILE->menu_specification,
+ $PROFILE->doc_base_specification,
+ $PROFILE->filesystem_hierarchy_standard,
+ );
+
+ my %by_shorthand = map { $_->shorthand => $_ } @MARKDOWN_CAPABLE;
+
+ # We use this to check for explicit links where it is possible to use
+ # a manual ref.
+ unless (%URLS) {
+ for my $manual (@MARKDOWN_CAPABLE) {
+
+ my $volume = $manual->shorthand;
+
+ for my $section_key ($manual->all){
+ my $entry = $manual->value($section_key);
+
+ my $url = $entry->{$section_key}{url};
+ next
+ unless length $url;
+
+ $URLS{$url} = "$volume $section_key";
+ }
+ }
+ }
+
+ if ( $see_also =~ m{^https?://bugs.debian.org/(\d++)$}
+ || $see_also
+ =~ m{^https?://bugs.debian.org/cgi-bin/bugreport.cgi\?/.*bug=(\d++).*$}
+ ) {
+ push(@issues, "replace '$see_also' with '#$1'");
+
+ } elsif (exists $URLS{$see_also}) {
+ push(@issues, "replace '$see_also' with '$URLS{$see_also}'");
+
+ } elsif ($see_also =~ m/^([\w-]++)\s++(\S++)$/) {
+
+ my $volume = $1;
+ my $section = $2;
+
+ if (exists $by_shorthand{$volume}) {
+
+ my $manual = $by_shorthand{$volume};
+
+ push(@issues, "unknown section '$section' in $volume")
+ unless length $manual->markdown_citation($section);
+
+ } else {
+ push(@issues, "unknown manual '$volume'");
+ }
+
+ } else {
+ # Check it is a valid reference like URLs or #123456
+ # NB: "policy 10.1" references already covered above
+ push(@issues, "unknown or malformed reference '$see_also'")
+ if $see_also !~ /^#\d+$/ # debbugs reference
+ && $see_also !~ m{^(?:ftp|https?)://} # browser URL
+ && $see_also !~ m{^/} # local file reference
+ && $see_also !~ m{[\w_-]+\(\d\w*\)$}; # man reference
+ }
+
+ return @issues;
+}
+
+sub _find_check {
+ my ($find_opt, $input) = @_;
+ $find_opt//= {};
+ my $filter = $find_opt->{'filter'};
+
+ if ($filter) {
+ local $_ = $input;
+ # filtered out?
+ return () unless $filter->($_);
+ }
+
+ if (-d $input) {
+ my (@result, $regex);
+ if ($find_opt->{'want-check-name'}) {
+ $regex = qr{^\Q$input\E/*};
+ }
+ my $wanted = sub {
+ if (defined $filter) {
+ local $_ = $_;
+ if (not $filter->($_)) {
+ # filtered out; if a dir - filter the
+ # entire dir.
+ $File::Find::prune = 1 if -d;
+ return;
+ }
+ }
+ return unless m/\.desc$/ and -e;
+ if ($regex) {
+ s/$regex//;
+ s/\.desc$//;
+ }
+ push @result, $_;
+ };
+ my $opt = {
+ 'wanted' => $wanted,
+ 'no_chdir' => 1,
+ };
+ File::Find::find($opt, $input);
+ return @result;
+ }
+
+ return ($input);
+}
+
+=item program_name_to_perl_paths(PROGNAME)
+
+Map the program name (e.g. C<$0>) to a list of directories or/and
+files that should be processed.
+
+This helper sub is mostly useful for splitting up slow tests run over
+all Perl scripts/modules in Lintian. This allows better use of
+multiple cores. Example:
+
+
+ t/scripts/my-test/
+ runner.pl
+ checks.t -> runner.pl
+ collection.t -> runner.pl
+ ...
+
+And then in runner.pl:
+
+ use Test::Lintian;
+
+ my @paths = program_name_to_perl_paths($0);
+ # test all files/dirs listed in @paths
+
+For a more concrete example, see t/scripts/01-critic/ and the
+files/symlinks beneath it.
+
+=cut
+
+{
+
+ my %SPECIAL_PATHS = (
+ 'docs-examples' => ['doc/examples/checks'],
+ 'test-scripts' => [qw(t/scripts t/templates)],
+ );
+
+ sub program_name_to_perl_paths {
+ my ($program) = @_;
+ # We need the basename before resolving the path (because
+ # afterwards it is "runner.pl" and we want it to be e.g.
+ # "checks.t" or "collections.t").
+ my $basename = basename($program, '.t');
+
+ if (exists($SPECIAL_PATHS{$basename})) {
+ return @{$SPECIAL_PATHS{$basename}};
+ }
+
+ return ($basename);
+ }
+}
+
+=back
+
+=cut
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
diff --git a/lib/Test/Lintian/Build.pm b/lib/Test/Lintian/Build.pm
new file mode 100644
index 0000000..b6819af
--- /dev/null
+++ b/lib/Test/Lintian/Build.pm
@@ -0,0 +1,163 @@
+# Copyright (C) 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 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
+
+package Test::Lintian::Build;
+
+=head1 NAME
+
+Test::Lintian::Build -- routines to prepare the work directories
+
+=head1 SYNOPSIS
+
+ use Test::Lintian::Build qw(build_subject);
+
+=head1 DESCRIPTION
+
+The routines in this module prepare the work directories in which the
+tests are run. To do so, they use the specifications in the test set.
+
+=cut
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Exporter qw(import);
+
+BEGIN {
+ our @EXPORT_OK = qw(
+ build_subject
+ );
+}
+
+use Carp;
+use Const::Fast;
+use Cwd;
+use IPC::Run3;
+use List::SomeUtils qw(any);
+use Path::Tiny;
+use Unicode::UTF8 qw(valid_utf8 encode_utf8);
+
+use Lintian::Util qw(utf8_clean_log);
+
+use Test::Lintian::ConfigFile qw(read_config);
+use Test::Lintian::Hooks qw(find_missing_prerequisites);
+
+const my $SLASH => q{/};
+const my $WAIT_STATUS_SHIFT => 8;
+
+=head1 FUNCTIONS
+
+=over 4
+
+=item build_subject(PATH)
+
+Populates a work directory RUN_PATH with data from the test located
+in SPEC_PATH. The optional parameter REBUILD forces a rebuild if true.
+
+=cut
+
+sub build_subject {
+ my ($sourcepath, $buildpath) = @_;
+
+ # check test architectures
+ die encode_utf8('DEB_HOST_ARCH is not set.')
+ unless (length $ENV{'DEB_HOST_ARCH'});
+
+ # read dynamic file names
+ my $runfiles = "$sourcepath/files";
+ my $files = read_config($runfiles);
+
+ # read dynamic case data
+ my $rundescpath
+ = $sourcepath . $SLASH . $files->unfolded_value('Fill-Values');
+ my $testcase = read_config($rundescpath);
+
+ # skip test if marked
+ my $skipfile = "$sourcepath/skip";
+ if (-e $skipfile) {
+ my $reason = path($skipfile)->slurp_utf8 || 'No reason given';
+ say encode_utf8("Skipping test: $reason");
+ return;
+ }
+
+ # skip if missing prerequisites
+ my $missing = find_missing_prerequisites($testcase);
+ if (length $missing) {
+ say encode_utf8("Missing prerequisites: $missing");
+ return;
+ }
+
+ path($buildpath)->remove_tree
+ if -e $buildpath;
+
+ path($buildpath)->mkpath;
+
+ # get lintian subject
+ croak encode_utf8('Could not get subject of Lintian examination.')
+ unless $testcase->declares('Build-Product');
+
+ my $build_product = $testcase->unfolded_value('Build-Product');
+ my $subject = "$buildpath/$build_product";
+
+ say encode_utf8("Building in $buildpath");
+
+ my $command = $testcase->unfolded_value('Build-Command');
+ if (length $command) {
+
+ my $savedir = Cwd::getcwd;
+ chdir($buildpath)
+ or die encode_utf8("Cannot change to directory $buildpath");
+
+ my $combined_bytes;
+
+ # array command breaks test files/contents/contains-build-path
+ run3($command, \undef, \$combined_bytes, \$combined_bytes);
+ my $status = ($? >> $WAIT_STATUS_SHIFT);
+
+ chdir($savedir)
+ or die encode_utf8("Cannot change to directory $savedir");
+
+ # sanitize log so it is UTF-8 from here on
+ my $utf8_bytes = utf8_clean_log($combined_bytes);
+ print $utf8_bytes;
+
+ croak encode_utf8("$command failed")
+ if $status;
+ }
+
+ croak encode_utf8('Build was unsuccessful.')
+ unless -e $subject;
+
+ die encode_utf8("Cannot link to build product $build_product")
+ if system("cd $buildpath; ln -s $build_product subject");
+
+ return;
+}
+
+=back
+
+=cut
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
diff --git a/lib/Test/Lintian/ConfigFile.pm b/lib/Test/Lintian/ConfigFile.pm
new file mode 100644
index 0000000..162b49c
--- /dev/null
+++ b/lib/Test/Lintian/ConfigFile.pm
@@ -0,0 +1,132 @@
+# Copyright (C) 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 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
+
+package Test::Lintian::ConfigFile;
+
+=head1 NAME
+
+Test::Lintian::ConfigFile -- generic helper routines for colon-delimited configuration files
+
+=head1 SYNOPSIS
+
+use Test::Lintian::ConfigFile qw(read_config);
+my $desc = read_config('t/tags/testname/desc');
+
+=head1 DESCRIPTION
+
+Routines for dealing with colon-delimited configuration files.
+
+=cut
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Exporter qw(import);
+
+BEGIN {
+ our @EXPORT_OK = qw(
+ read_config
+ write_config
+ );
+}
+
+use Carp;
+use Const::Fast;
+use List::SomeUtils qw(any);
+use Path::Tiny;
+use Unicode::UTF8 qw(encode_utf8);
+
+use Lintian::Deb822;
+
+const my $SPACE => q{ };
+const my $COLON => q{:};
+const my $NEWLINE => qq{\n};
+
+=head1 FUNCTIONS
+
+=over 4
+
+=item read_config(PATH, HASHREF)
+
+Reads the configuration file located at PATH into a hash and
+returns it. When also passed a HASHREF, will fill that instead.
+
+=cut
+
+sub read_config {
+ my ($configpath) = @_;
+
+ croak encode_utf8("Cannot find file $configpath.")
+ unless -e $configpath;
+
+ my $deb822 = Lintian::Deb822->new;
+ my @sections = $deb822->read_file($configpath);
+ die encode_utf8("$configpath does not have exactly one paragraph")
+ unless @sections == 1;
+
+ my $config = $sections[0];
+
+ return $config;
+}
+
+=item write_config(TEST_CASE, PATH)
+
+Write the config described by hash reference TEST_CASE to the file named PATH.
+
+=cut
+
+sub write_config {
+ my ($testcase, $path) = @_;
+
+ my $desc = path($path);
+ $desc->remove;
+
+ my @lines;
+ for my $name (sort $testcase->names) {
+
+ my @elements = $testcase->trimmed_list($name);
+
+ # multi-line output for some fields
+ if (@elements > 1
+ && any { fc eq fc($name) } qw(Test-For Test-Against)) {
+ push(@lines, $name . $COLON . $NEWLINE);
+ push(@lines, $SPACE . $_ . $NEWLINE) for @elements;
+ next;
+ }
+
+ push(@lines,
+ $name . $COLON . $SPACE . $testcase->value($name) . $NEWLINE);
+ }
+
+ $desc->append_utf8(@lines);
+
+ return;
+}
+
+=back
+
+=cut
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
diff --git a/lib/Test/Lintian/Filter.pm b/lib/Test/Lintian/Filter.pm
new file mode 100644
index 0000000..4b6ea8a
--- /dev/null
+++ b/lib/Test/Lintian/Filter.pm
@@ -0,0 +1,378 @@
+# 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.
+
+package Test::Lintian::Filter;
+
+=head1 NAME
+
+Test::Lintian::Filter -- Functions to select with tests to run
+
+=head1 SYNOPSIS
+
+ use Test::Lintian::Filter qw(find_selected_lintian_testpaths);
+ my @testpaths = find_selected_lintian_testpaths('suite:changes');
+
+=head1 DESCRIPTION
+
+Functions that parse the optional argument 'only_run' to find the
+tests that are supposed to run.
+
+=cut
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Exporter qw(import);
+
+BEGIN {
+ our @EXPORT_OK = qw(
+ find_selected_scripts
+ find_selected_lintian_testpaths
+ );
+}
+
+use Carp;
+use Const::Fast;
+use File::Spec::Functions qw(rel2abs splitpath catpath);
+use File::Find::Rule;
+use List::SomeUtils qw(uniq none);
+use List::Util qw(any all);
+use Path::Tiny;
+use Text::CSV;
+use Unicode::UTF8 qw(encode_utf8);
+
+use Lintian::Profile;
+use Test::Lintian::ConfigFile qw(read_config);
+
+my @LINTIAN_SUITES = qw(recipes);
+
+const my $EMPTY => q{};
+const my $SPACE => q{ };
+const my $VERTICAL_BAR => q{|};
+const my $DESC => 'desc';
+const my $SEPARATED_BY_COLON => qr/([^:]+):([^:]+)/;
+
+=head1 FUNCTIONS
+
+=over 4
+
+=item get_suitepath(TEST_SET, SUITE)
+
+Returns a string containing all test belonging to suite SUITE relative
+to path TEST_SET.
+
+=cut
+
+sub get_suitepath {
+ my ($basepath, $suite) = @_;
+ my $suitepath = rel2abs($suite, $basepath);
+
+ croak encode_utf8("Cannot find suite $suite in $basepath")
+ unless -d $suitepath;
+
+ return $suitepath;
+}
+
+=item find_selected_scripts(SCRIPT_PATH, ONLY_RUN)
+
+Find all test scripts in SCRIPT_PATH that are identified by the
+user's selection string ONLY_RUN.
+
+=cut
+
+sub find_selected_scripts {
+ my ($scriptpath, $onlyrun) = @_;
+
+ my @found;
+
+ my @selectors = split(m/\s*,\s*/, $onlyrun//$EMPTY);
+
+ if ((any { $_ eq 'suite:scripts' } @selectors) || !length $onlyrun) {
+ @found = File::Find::Rule->file()->name('*.t')->in($scriptpath);
+ } else {
+ foreach my $selector (@selectors) {
+ my ($prefix, $lookfor) = ($selector =~ /$SEPARATED_BY_COLON/);
+
+ next if defined $prefix && $prefix ne 'script';
+ $lookfor = $selector unless defined $prefix;
+
+ # look for files with the standard suffix
+ my $withsuffix = rel2abs("$lookfor.t", $scriptpath);
+ push(@found, $withsuffix) if -e $withsuffix;
+
+ # look for script with exact name
+ my $exactpath = rel2abs($lookfor, $scriptpath);
+ push(@found, $exactpath) if -e $exactpath;
+
+ # also add entire directory if name matches
+ push(@found, File::Find::Rule->file()->name('*.t')->in($exactpath))
+ if -d $exactpath;
+ }
+ }
+
+ my @sorted = sort +uniq @found;
+
+ return @sorted;
+}
+
+=item find_selected_lintian_testpaths(TEST_SET, ONLY_RUN)
+
+Find all those test paths with Lintian tests located in the directory
+TEST_SET and identified by the user's selection string ONLY_RUN.
+
+=cut
+
+sub find_selected_lintian_testpaths {
+
+ my ($testset, $onlyrun) = @_;
+
+ my $filter = {
+ 'tag' => [],
+ 'suite' => [],
+ 'test' => [],
+ 'check' => [],
+ 'skeleton' => [],
+ };
+ my @filter_no_prefix;
+
+ if (!length $onlyrun) {
+ $filter->{suite} = [@LINTIAN_SUITES];
+ } else {
+
+ my @selectors = split(m/\s*,\s*/, $onlyrun);
+
+ foreach my $selector (@selectors) {
+
+ foreach my $wanted (keys %{$filter}) {
+ my ($prefix, $lookfor) = ($selector =~ /$SEPARATED_BY_COLON/);
+
+ next if defined $prefix && $prefix ne $wanted;
+
+ push(@{$filter->{$wanted}}, $lookfor) if length $lookfor;
+ push(@filter_no_prefix, $selector) unless length $lookfor;
+ }
+ }
+ }
+
+ my $profile = Lintian::Profile->new;
+ $profile->load(undef, undef, 0);
+
+ my @found;
+ foreach my $suite (sort @LINTIAN_SUITES) {
+
+ my @insuite;
+ my $suitepath = get_suitepath($testset, $suite);
+
+ # find all tests for selected suites
+ if (any { $_ eq $suite } @{$filter->{suite}}) {
+ push(@insuite, find_all_testpaths($suitepath));
+ }
+
+ # find explicitly selected tests
+ foreach my $testname (@{$filter->{test}}) {
+ my @withtests = find_testpaths_by_name($suitepath, $testname);
+ push(@insuite, @withtests);
+ }
+
+ # find tests for selected checks and tags
+ if (scalar @{$filter->{check}} || scalar @{$filter->{tag}}) {
+
+ my %wanted = map { $_ => 1 } @{$filter->{check}};
+
+ for my $tag_name (@{$filter->{tag}}) {
+
+ my $tag = $profile->get_tag($tag_name);
+ unless ($tag) {
+ say encode_utf8("Tag $tag_name not found");
+ return ();
+ }
+
+ if (none { $tag_name eq $_ } $profile->enabled_tags) {
+ say encode_utf8("Tag $tag_name not enabled");
+ return ();
+ }
+
+ $wanted{$tag->check} = 1;
+ }
+
+ for my $testpath (find_all_testpaths($suitepath)) {
+ my $desc = read_config("$testpath/eval/" . $DESC);
+
+ next
+ unless $desc->declares('Check');
+
+ for my $check ($desc->trimmed_list('Check')) {
+ push(@insuite, $testpath)
+ if exists $wanted{$check};
+ }
+ }
+ }
+
+ # find tests for selected skeleton
+ if (scalar @{$filter->{skeleton}}) {
+
+ my %wanted = map { $_ => 1 } @{$filter->{skeleton}};
+
+ for my $testpath (find_all_testpaths($suitepath)) {
+ my $desc = read_config("$testpath/build-spec/fill-values");
+
+ next
+ unless $desc->declares('Skeleton');
+
+ my $skeleton = $desc->unfolded_value('Skeleton');
+ push(@insuite, $testpath)
+ if exists $wanted{$skeleton};
+ }
+ }
+
+ # guess what was meant by selection without prefix
+ for my $parameter (@filter_no_prefix) {
+ push(@insuite,find_testpaths_by_name($suitepath, $parameter));
+
+ if ($parameter eq 'legacy'
+ || exists $profile->check_module_by_name->{$parameter}) {
+
+ push(@insuite,
+ find_testpaths_by_name($suitepath, "$parameter-*"));
+ }
+ }
+
+ push(@found, sort +uniq @insuite);
+ }
+
+ return @found;
+}
+
+=item find_all_testpaths(PATH)
+
+Returns an array containing all test paths located under PATH. They
+are identified as test paths by a specially named file containing
+the test description (presently 'desc').
+
+=cut
+
+sub find_all_testpaths {
+ my ($directory) = @_;
+ my @descfiles = File::Find::Rule->file()->name($DESC)->in($directory);
+
+ my @testpaths= map { path($_)->parent->parent->stringify }@descfiles;
+
+ return @testpaths;
+}
+
+=item find_testpaths_by_name(PATH, NAME)
+
+Returns an array containing all test paths with the name NAME
+located under PATH. The test paths are identified as such
+by a specially named file containing the test description
+(presently 'desc').
+
+=cut
+
+sub find_testpaths_by_name {
+ my ($path, $name) = @_;
+
+ my @named = File::Find::Rule->directory()->name($name)->in($path);
+ my @testpaths= grep { defined }
+ map { -e rel2abs('eval/' . $DESC, $_) ? $_ : undef } @named;
+
+ return @testpaths;
+}
+
+=item find_all_tags(TEST_PATH)
+
+Returns an array containing all tags that somehow concern the test
+located in TEST_PATH.
+
+=cut
+
+sub find_all_tags {
+ my ($testpath) = @_;
+
+ my $desc = read_config("$testpath/eval/" . $DESC);
+
+ return $EMPTY
+ unless $desc->declares('Check');
+
+ my $profile = Lintian::Profile->new;
+ $profile->load(undef, undef, 0);
+
+ my @check_names = $desc->trimmed_list('Check');
+ my @unknown
+ = grep { !exists $profile->check_module_by_name->{$_} } @check_names;
+
+ die encode_utf8('Unknown Lintian checks: ' . join($SPACE, @unknown))
+ if @unknown;
+
+ my %tags;
+ for my $name (@check_names) {
+ $tags{$_} = 1 for @{$profile->tag_names_for_check->{$name}};
+ }
+
+ return keys %tags
+ unless $desc->declares('Test-Against');
+
+ # read hints from specification
+ my $temp = Path::Tiny->tempfile;
+ die encode_utf8("hintextract failed: $!")
+ if system('private/hintextract', '-f', 'EWI', "$testpath/hints",
+ $temp->stringify);
+ my @lines = $temp->lines_utf8({ chomp => 1 });
+
+ my $csv = Text::CSV->new({ sep_char => $VERTICAL_BAR });
+
+ my %expected;
+ foreach my $line (@lines) {
+
+ my $status = $csv->parse($line);
+ die encode_utf8("Cannot parse line $line: " . $csv->error_diag)
+ unless $status;
+
+ my ($type, $package, $name, $details) = $csv->fields;
+
+ die encode_utf8("Cannot parse line $line")
+ unless all { length } ($type, $package, $name);
+
+ $expected{$name} = 1;
+ }
+
+ # remove tags not appearing in specification
+ foreach my $name (keys %tags) {
+ delete $tags{$name}
+ unless $expected{$name};
+ }
+
+ # add tags listed in Test-Against
+ my @test_against = $desc->trimmed_list('Test-Against');
+ $tags{$_} = 1 for @test_against;
+
+ return keys %tags;
+}
+
+=back
+
+=cut
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
diff --git a/lib/Test/Lintian/Helper.pm b/lib/Test/Lintian/Helper.pm
new file mode 100644
index 0000000..518d036
--- /dev/null
+++ b/lib/Test/Lintian/Helper.pm
@@ -0,0 +1,198 @@
+# Copyright (C) 1998 Richard Braakman
+# Copyright (C) 2008 Frank Lichtenheld
+# Copyright (C) 2008, 2009 Russ Allbery
+# Copyright (C) 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 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
+
+package Test::Lintian::Helper;
+
+=head1 NAME
+
+Test::Lintian::Helper -- Helper functions for various testing parts
+
+=head1 SYNOPSIS
+
+ use Test::Lintian::Helper qw(get_latest_policy);
+ my $policy_version = get_latest_policy();
+
+=head1 DESCRIPTION
+
+Helper functions for preparing and running Lintian tests.
+
+=cut
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Exporter qw(import);
+
+BEGIN {
+ our @EXPORT_OK = qw(
+ cache_dpkg_architecture_values
+ get_latest_policy
+ get_recommended_debhelper_version
+ copy_dir_contents
+ rfc822date
+ );
+}
+
+use Carp;
+use File::Spec::Functions qw(abs2rel rel2abs);
+use File::Path qw(remove_tree);
+use Path::Tiny;
+use POSIX qw(locale_h strftime);
+use Unicode::UTF8 qw(encode_utf8 decode_utf8);
+
+use Lintian::IPC::Run3 qw(safe_qx);
+use Lintian::Profile;
+
+=head1 FUNCTIONS
+
+=over 4
+
+=item cache_dpkg_architecture_values()
+
+Ensures that the output from dpkg-architecture has been cached.
+
+=cut
+
+sub cache_dpkg_architecture_values {
+
+ my $output = decode_utf8(safe_qx('dpkg-architecture'));
+
+ die encode_utf8('dpkg-architecture failed')
+ if $?;
+
+ $output = decode_utf8($output)
+ if length $output;
+
+ my @lines = split(/\n/, $output);
+
+ for my $line (@lines) {
+ my ($k, $v) = split(/=/, $line, 2);
+ $ENV{$k} = $v;
+ }
+
+ return;
+}
+
+=item get_latest_policy()
+
+Returns a list with two elements. The first is the most recent version
+of the Debian policy. The second is its effective date.
+
+=cut
+
+sub get_latest_policy {
+ my $profile = Lintian::Profile->new;
+ $profile->load(undef, undef, 0);
+
+ my $releases = $profile->data->policy_releases;
+
+ my $version = $releases->latest_version;
+ die encode_utf8('Could not get latest policy version.')
+ unless defined $version;
+ my $epoch = $releases->epoch($version);
+ die encode_utf8('Could not get latest policy date.')
+ unless defined $epoch;
+
+ return ($version, $epoch);
+}
+
+=item get_recommended_debhelper_version()
+
+Returns the version of debhelper recommended in 'debhelper/compat-level'
+via Lintian::Data, relative to the established LINTIAN_BASE.
+
+=cut
+
+sub get_recommended_debhelper_version {
+ my $profile = Lintian::Profile->new;
+ $profile->load(undef, undef, 0);
+
+ my $compat_level = $profile->data->debhelper_levels;
+
+ return $compat_level->value('recommended');
+}
+
+=item copy_dir_contents(SRC_DIR, TARGET_DIR)
+
+Populates TARGET_DIR with files/dirs from SRC_DIR, preserving all attributes but
+dereferencing links. For an empty directory, no dummy file is required.
+
+=cut
+
+sub copy_dir_contents {
+ my ($source, $destination) = @_;
+
+ # 'cp -r' cannot overwrite directories with files or vice versa
+ my @paths = File::Find::Rule->in($source);
+ foreach my $path (@paths) {
+
+ my $relative = abs2rel($path, $source);
+ my $prospective = rel2abs($relative, $destination);
+
+ # recursively delete directories to be replaced by a file
+ remove_tree($prospective)
+ if -d $prospective && -e $path && !-d _;
+
+ # remove files to be replaced by a directory
+ if (-e $prospective && !-d _ && -d $path) {
+ unlink($prospective)
+ or die encode_utf8("Cannot unlink $prospective");
+ }
+ }
+
+ # 'cp -r' with a dot will error without files present
+ if (scalar path($source)->children) {
+
+ system('cp', '-rp', "$source/.", '-t', $destination)== 0
+ or croak encode_utf8("Could not copy $source to $destination: $!");
+ }
+ return 1;
+}
+
+=item rfc822date(EPOCH)
+
+Returns a string with the date and time described by EPOCH, formatted
+according to RFC822.
+
+=cut
+
+sub rfc822date {
+ my ($epoch) = @_;
+
+ my $old_locale = setlocale(LC_TIME, 'C');
+ my $datestring = strftime('%a, %d %b %Y %H:%M:%S %z', localtime($epoch));
+ setlocale(LC_TIME, $old_locale);
+
+ return $datestring;
+}
+
+=back
+
+=cut
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
diff --git a/lib/Test/Lintian/Hooks.pm b/lib/Test/Lintian/Hooks.pm
new file mode 100644
index 0000000..4c8d848
--- /dev/null
+++ b/lib/Test/Lintian/Hooks.pm
@@ -0,0 +1,228 @@
+# Copyright (C) 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 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
+
+package Test::Lintian::Hooks;
+
+=head1 NAME
+
+Test::Lintian::Hooks -- hook routines for the test runners
+
+=head1 SYNOPSIS
+
+ use Test::Lintian::Hooks qw(sed_hook);
+ sed_hook('script.sed', 'input.file');
+
+=head1 DESCRIPTION
+
+Various hook routines for the test runners.
+
+=cut
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Exporter qw(import);
+
+BEGIN {
+ our @EXPORT_OK = qw(
+ sed_hook
+ sort_lines
+ calibrate
+ find_missing_prerequisites
+ );
+}
+
+use Capture::Tiny qw(capture_merged);
+use Carp;
+use Const::Fast;
+use Cwd qw(getcwd);
+use File::Basename;
+use File::Find::Rule;
+use File::Path;
+use File::stat;
+use IPC::Run3;
+use List::SomeUtils qw(any);
+use Path::Tiny;
+use Unicode::UTF8 qw(encode_utf8 decode_utf8);
+
+const my $NEWLINE => qq{\n};
+const my $WAIT_STATUS_SHIFT => 8;
+
+=head1 FUNCTIONS
+
+=over 4
+
+=item sed_hook(SCRIPT, SUBJECT, OUTPUT)
+
+Runs the parser sed on file SUBJECT using the instructions in SCRIPT
+and places the result in the file OUTPUT.
+
+=cut
+
+sub sed_hook {
+ my ($script, $path, $output) = @_;
+
+ croak encode_utf8("Parser script $script does not exist.")
+ unless -e $script;
+
+ my @command = (qw{sed -r -f}, $script, $path);
+ my $bytes;
+ run3(\@command, \undef, \$bytes);
+ my $status = ($? >> $WAIT_STATUS_SHIFT);
+
+ croak encode_utf8("Hook failed: sed -ri -f $script $path > $output: $!")
+ if $status;
+
+ # already in bytes
+ path($output)->spew($bytes);
+
+ croak encode_utf8("Did not create parser output file $output.")
+ unless -e $output;
+
+ return $output;
+}
+
+=item sort_lines(UNSORTED, SORTED)
+
+Sorts the file UNSORTED line by line and places the result into the
+file SORTED.
+
+=cut
+
+sub sort_lines {
+ my ($path, $sorted) = @_;
+
+ open(my $rfd, '<', $path)
+ or croak encode_utf8("Could not open pre-sort file $path: $!");
+ my @lines = sort map { decode_utf8($_) } <$rfd>;
+ close $rfd
+ or carp encode_utf8("Could not close open pre-sort file $path: $!");
+
+ open(my $wfd, '>', $sorted)
+ or croak encode_utf8("Could not open sorted file $sorted: $!");
+ print {$wfd} encode_utf8($_) for @lines;
+ close $wfd
+ or carp encode_utf8("Could not close sorted file $sorted: $!");
+
+ return $sorted;
+}
+
+=item calibrate(SCRIPT, ACTUAL, EXPECTED, CALIBRATED)
+
+Executes calibration script SCRIPT with the three arguments EXPECTED,
+ACTUAL and CALIBRATED, all of which are file paths. Please note that
+the order of arguments in this function corresponds to the
+bookkeeping logic of ACTUAL vs EXPECTED. The order for the script is
+different.
+
+=cut
+
+sub calibrate {
+ my ($hook, $actual, $expected, $calibrated) = @_;
+
+ if (-x $hook) {
+ system($hook, $expected, $actual, $calibrated) == 0
+ or croak encode_utf8("Hook $hook failed on $actual: $!");
+ croak encode_utf8("No calibrated hints created in $calibrated")
+ unless -e $calibrated;
+ return $calibrated;
+ }
+ return $expected;
+}
+
+=item find_missing_prerequisites(TEST_CASE)
+
+Returns a string with missing dependencies, if applicable, that would
+be necessary to run the test described by hash DESC.
+
+=cut
+
+sub find_missing_prerequisites {
+ my ($testcase) = @_;
+
+ # without prerequisites, no need to look
+ return undef
+ unless any { $testcase->declares($_) }
+ qw(Build-Depends Build-Conflicts Test-Depends Test-Conflicts);
+
+ # create a temporary file
+ my $temp = Path::Tiny->tempfile(
+ TEMPLATE => 'lintian-test-build-depends-XXXXXXXXX');
+ my @lines;
+
+ # dpkg-checkbuilddeps requires a Source: field
+ push(@lines, 'Source: bd-test-pkg');
+
+ my $build_depends = join(
+ ', ',
+ grep { length }(
+ $testcase->value('Build-Depends'),$testcase->value('Test-Depends')
+ )
+ );
+
+ push(@lines, "Build-Depends: $build_depends")
+ if length $build_depends;
+
+ my $build_conflicts = join(
+ ', ',
+ grep { length }(
+ $testcase->value('Build-Conflicts'),
+ $testcase->value('Test-Conflicts')
+ )
+ );
+ push(@lines, "Build-Conflicts: $build_conflicts")
+ if length $build_conflicts;
+
+ $temp->spew_utf8(join($NEWLINE, @lines) . $NEWLINE);
+
+ # run dpkg-checkbuilddeps
+ my $command = "dpkg-checkbuilddeps $temp";
+ my ($missing, $status) = capture_merged { system($command); };
+ $status >>= $WAIT_STATUS_SHIFT;
+
+ $missing = decode_utf8($missing)
+ if length $missing;
+
+ die encode_utf8("$command failed: $missing")
+ if !$status && length $missing;
+
+ # parse for missing prerequisites
+ if ($missing =~ s{\A dpkg-checkbuilddeps: [ ] (?:error: [ ])? }{}xsm) {
+ $missing =~ s{Unmet build dependencies}{Unmet}gi;
+ chomp($missing);
+ # expect exactly one line.
+ die encode_utf8("Unexpected output from dpkg-checkbuilddeps: $missing")
+ if $missing =~ s{\n}{\\n}gxsm;
+ return $missing;
+ }
+
+ return undef;
+}
+
+=back
+
+=cut
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
diff --git a/lib/Test/Lintian/Output/EWI.pm b/lib/Test/Lintian/Output/EWI.pm
new file mode 100644
index 0000000..74fab49
--- /dev/null
+++ b/lib/Test/Lintian/Output/EWI.pm
@@ -0,0 +1,117 @@
+# Copyright (C) 2019 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
+
+package Test::Lintian::Output::EWI;
+
+=head1 NAME
+
+Test::Lintian::Output::EWI -- routines to process EWI hints
+
+=head1 SYNOPSIS
+
+ use Path::Tiny;
+ use Test::Lintian::Output::EWI qw(to_universal);
+
+ my $ewi = path("path to an EWI hint file")->slurp_utf8;
+ my $universal = to_universal($ewi);
+
+=head1 DESCRIPTION
+
+Helper routines to deal with C<EWI> hints and hint files
+
+=cut
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Exporter qw(import);
+
+BEGIN {
+ our @EXPORT_OK = qw(
+ to_universal
+ );
+}
+
+use Carp;
+use Const::Fast;
+use List::Util qw(all);
+use Unicode::UTF8 qw(encode_utf8);
+
+use Test::Lintian::Output::Universal qw(universal_string order);
+
+const my $EMPTY => q{};
+const my $NEWLINE => qq{\n};
+
+=head1 FUNCTIONS
+
+=over 4
+
+=item to_universal(STRING)
+
+Converts the C<EWI> hint data contained in STRING to universal hints.
+They are likewise delivered in a multi-line string.
+
+=cut
+
+sub to_universal {
+ my ($ewi) = @_;
+
+ my @unsorted;
+
+ my @lines = split($NEWLINE, $ewi);
+ chomp @lines;
+
+ foreach my $line (@lines) {
+
+ # no hint in this line
+ next if $line =~ /^N: /;
+
+ # look for "EWI: package[ type]: name details"
+ my ($code, $package, $type, $name, $details)
+ = $line=~ /^(.): (\S+)(?: (changes|source|udeb))?: (\S+)(?: (.*))?$/;
+
+ # for binary packages, the type field is empty
+ $type //= 'binary';
+
+ croak encode_utf8("Cannot parse line $line")
+ unless all { length } ($code, $package, $type, $name);
+
+ my $converted = universal_string($package, $type, $name, $details);
+ push(@unsorted, $converted);
+ }
+
+ my @sorted = reverse sort { order($a) cmp order($b) } @unsorted;
+
+ my $universal = $EMPTY;
+ $universal .= $_ . $NEWLINE for @sorted;
+
+ return $universal;
+}
+
+=back
+
+=cut
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
diff --git a/lib/Test/Lintian/Output/Universal.pm b/lib/Test/Lintian/Output/Universal.pm
new file mode 100644
index 0000000..707b958
--- /dev/null
+++ b/lib/Test/Lintian/Output/Universal.pm
@@ -0,0 +1,189 @@
+# Copyright (C) 2019 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
+
+package Test::Lintian::Output::Universal;
+
+=head1 NAME
+
+Test::Lintian::Output::Universal -- routines to process universal hints
+
+=head1 SYNOPSIS
+
+ use Test::Lintian::Output::Universal qw(get_tag_names);
+
+ my $filepath = "path to a universal hint file";
+ my @tags = get_tag_names($filepath);
+
+=head1 DESCRIPTION
+
+Helper routines to deal with universal hints and hint files. This is an
+abstract format that has the minimum information found in all Lintian
+output formats.
+
+=cut
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Exporter qw(import);
+
+BEGIN {
+ our @EXPORT_OK = qw(
+ get_tag_names
+ order
+ package_name
+ package_type
+ tag_name
+ parse_line
+ universal_string
+ );
+}
+
+use Carp;
+use Const::Fast;
+use List::SomeUtils qw(uniq);
+use List::Util qw(all);
+use Path::Tiny;
+use Unicode::UTF8 qw(encode_utf8);
+
+const my $SPACE => q{ };
+const my $COLON => q{:};
+const my $LPARENS => q{(};
+const my $RPARENS => q{)};
+
+=head1 FUNCTIONS
+
+=over 4
+
+=item get_tag_names(PATH)
+
+Gets all the tag names mentioned in universal hint file located
+at PATH.
+
+=cut
+
+sub get_tag_names {
+ my ($path) = @_;
+
+ my @lines = path($path)->lines_utf8({ chomp => 1 });
+ my @names = map { tag_name($_) } @lines;
+
+ return uniq @names;
+}
+
+=item order
+
+=cut
+
+sub order {
+ my ($line) = @_;
+
+ return package_type($line) . $line;
+}
+
+=item package_name
+
+=cut
+
+sub package_name {
+ my ($line) = @_;
+
+ my ($package, undef, undef, undef) = parse_line($line);
+ return $package;
+}
+
+=item package_type
+
+=cut
+
+sub package_type {
+ my ($line) = @_;
+
+ my (undef, $type, undef, undef) = parse_line($line);
+ return $type;
+}
+
+=item tag_name
+
+=cut
+
+sub tag_name {
+ my ($line) = @_;
+
+ my (undef, undef, $name, undef) = parse_line($line);
+ return $name;
+}
+
+=item parse_line
+
+=cut
+
+sub parse_line {
+ my ($line) = @_;
+
+ my ($package, $type, $name, $details)
+ = $line =~ qr/^(\S+)\s+\(([^)]+)\):\s+(\S+)(?:\s+(.*))?$/;
+
+ croak encode_utf8("Cannot parse line $line")
+ unless all { length } ($package, $type, $name);
+
+ return ($package, $type, $name, $details);
+}
+
+=item universal_string
+
+=cut
+
+sub universal_string {
+ my ($package, $type, $name, $details) = @_;
+
+ croak encode_utf8('Need a package name')
+ unless length $package;
+ croak encode_utf8('Need a package type')
+ unless length $type;
+ croak encode_utf8('Need a tag name')
+ unless length $name;
+
+ my $line
+ = $package. $SPACE. $LPARENS. $type. $RPARENS. $COLON. $SPACE. $name;
+ $line .= $SPACE . $details
+ if length $details;
+
+ return $line;
+}
+
+=back
+
+=head1 AUTHOR
+
+Originally written by Felix Lechner <felix.lechner@lease-up.com> for Lintian.
+
+=head1 SEE ALSO
+
+lintian(1)
+
+=cut
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
diff --git a/lib/Test/Lintian/Prepare.pm b/lib/Test/Lintian/Prepare.pm
new file mode 100644
index 0000000..8914fcc
--- /dev/null
+++ b/lib/Test/Lintian/Prepare.pm
@@ -0,0 +1,551 @@
+# Copyright (C) 2018-2020 Felix Lechner
+# Copyright (C) 2019 Chris Lamb <lamby@debian.org>
+#
+# 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
+
+package Test::Lintian::Prepare;
+
+=head1 NAME
+
+Test::Lintian::Prepare -- routines to prepare the work directories
+
+=head1 SYNOPSIS
+
+ use Test::Lintian::Prepare qw(prepare);
+
+=head1 DESCRIPTION
+
+The routines in this module prepare the work directories in which the
+tests are run. To do so, they use the specifications in the test set.
+
+=cut
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Exporter qw(import);
+
+BEGIN {
+ our @EXPORT_OK = qw(
+ prepare
+ filleval
+ );
+}
+
+use Carp;
+use Const::Fast;
+use Cwd qw(getcwd);
+use File::Copy;
+use File::Find::Rule;
+use File::Path qw(make_path remove_tree);
+use File::stat;
+use List::Util qw(max);
+use Path::Tiny;
+use Text::Template;
+use Unicode::UTF8 qw(encode_utf8);
+
+use Lintian::Deb822::Section;
+
+use Test::Lintian::ConfigFile qw(read_config write_config);
+use Test::Lintian::Helper qw(rfc822date copy_dir_contents);
+use Test::Lintian::Templates
+ qw(copy_skeleton_template_sets remove_surplus_templates fill_skeleton_templates);
+
+const my $EMPTY => q{};
+const my $SPACE => q{ };
+const my $SLASH => q{/};
+const my $COMMA => q{,};
+
+=head1 FUNCTIONS
+
+=over 4
+
+=item prepare(SPEC_PATH, SOURCE_PATH, TEST_SET, REBUILD)
+
+Populates a work directory SOURCE_PATH with data from the test located
+in SPEC_PATH. The optional parameter REBUILD forces a rebuild if true.
+
+=cut
+
+sub prepare {
+ my ($specpath, $sourcepath, $testset, $force_rebuild)= @_;
+
+ say encode_utf8('------- Preparation starts here -------');
+ say encode_utf8("Work directory is $sourcepath.");
+
+ # for template fill, earliest date without timewarp warning
+ my $data_epoch = $ENV{'POLICY_EPOCH'}//time;
+
+ # read defaults
+ my $defaultspath = "$testset/defaults";
+
+ # read default file names
+ my $defaultfilespath = "$defaultspath/files";
+ die encode_utf8("Cannot find $defaultfilespath")
+ unless -e $defaultfilespath;
+
+ # read file and adjust data age threshold
+ my $files = read_config($defaultfilespath);
+ # $data_epoch= max($data_epoch, stat($defaultfilespath)->mtime);
+
+ # read test data
+ my $descpath = $specpath . $SLASH . $files->unfolded_value('Fill-Values');
+ my $desc = read_config($descpath);
+ # $data_epoch= max($data_epoch, stat($descpath)->mtime);
+
+ # read test defaults
+ my $descdefaultspath
+ = $defaultspath . $SLASH . $files->unfolded_value('Fill-Values');
+ my $defaults = read_config($descdefaultspath);
+ # $data_epoch= max($data_epoch, stat($descdefaultspath)->mtime);
+
+ # start with a shallow copy of defaults
+ my $testcase = Lintian::Deb822::Section->new;
+ $testcase->store($_, $defaults->value($_)) for $defaults->names;
+
+ die encode_utf8("Name missing for $specpath")
+ unless $desc->declares('Testname');
+
+ die encode_utf8('Outdated test specification (./debian/debian exists).')
+ if -e "$specpath/debian/debian";
+
+ if (-d $sourcepath) {
+
+ # check for old build artifacts
+ my $buildstamp = "$sourcepath/build-stamp";
+ say encode_utf8('Found old build artifact.') if -e $buildstamp;
+
+ # check for old debian/debian directory
+ my $olddebiandir = "$sourcepath/debian/debian";
+ say encode_utf8('Found old debian/debian directory.')
+ if -e $olddebiandir;
+
+ # check for rebuild demand
+ say encode_utf8('Forcing rebuild.') if $force_rebuild;
+
+ # delete work directory
+ if($force_rebuild || -e $buildstamp || -e $olddebiandir) {
+ say encode_utf8("Removing work directory $sourcepath.");
+ remove_tree($sourcepath);
+ }
+ }
+
+ # create work directory
+ unless (-d $sourcepath) {
+ say encode_utf8("Creating directory $sourcepath.");
+ make_path($sourcepath);
+ }
+
+ # delete old test scripts
+ my @oldrunners = File::Find::Rule->file->name('*.t')->in($sourcepath);
+ if (@oldrunners) {
+ unlink(@oldrunners)
+ or die encode_utf8("Cannot unlink @oldrunners");
+ }
+
+ my $skeletonname = $desc->unfolded_value('Skeleton');
+ if (length $skeletonname) {
+
+ # load skeleton
+ my $skeletonpath = "$testset/skeletons/$skeletonname";
+ my $skeleton = read_config($skeletonpath);
+
+ $testcase->store($_, $skeleton->value($_)) for $skeleton->names;
+ }
+
+ # populate working directory with specified template sets
+ copy_skeleton_template_sets($testcase->value('Template-Sets'),
+ $sourcepath, $testset)
+ if $testcase->declares('Template-Sets');
+
+ # delete templates for which we have originals
+ remove_surplus_templates($specpath, $sourcepath);
+
+ # copy test specification to working directory
+ my $offset = path($specpath)->relative($testset)->stringify;
+ say encode_utf8(
+ "Copy test specification $offset from $testset to $sourcepath.");
+ copy_dir_contents($specpath, $sourcepath);
+
+ my $valuefolder = $testcase->unfolded_value('Fill-Values-Folder');
+ if (length $valuefolder) {
+
+ # load all the values in the fill values folder
+ my $valuepath = "$sourcepath/$valuefolder";
+ my @filepaths
+ = File::Find::Rule->file->name('*.values')->in($valuepath);
+
+ for my $filepath (sort @filepaths) {
+ my $fill_values = read_config($filepath);
+
+ $testcase->store($_, $fill_values->value($_))
+ for $fill_values->names;
+ }
+ }
+
+ # add individual settings after skeleton
+ $testcase->store($_, $desc->value($_)) for $desc->names;
+
+ # record path to specification
+ $testcase->store('Spec-Path', $specpath);
+
+ # record path to specification
+ $testcase->store('Source-Path', $sourcepath);
+
+ # add other helpful info to testcase
+ $testcase->store('Source', $testcase->unfolded_value('Testname'))
+ unless $testcase->declares('Source');
+
+ # record our effective data age as date, unless given
+ $testcase->store('Date', rfc822date($data_epoch))
+ unless $testcase->declares('Date');
+
+ warn encode_utf8('Cannot override Architecture: in test '
+ . $testcase->unfolded_value('Testname'))
+ if $testcase->declares('Architecture');
+
+ die encode_utf8('DEB_HOST_ARCH is not set.')
+ unless defined $ENV{'DEB_HOST_ARCH'};
+ $testcase->store('Host-Architecture', $ENV{'DEB_HOST_ARCH'});
+
+ die encode_utf8('Could not get POLICY_VERSION.')
+ unless defined $ENV{'POLICY_VERSION'};
+ $testcase->store('Standards-Version', $ENV{'POLICY_VERSION'})
+ unless $testcase->declares('Standards-Version');
+
+ die encode_utf8('Could not get DEFAULT_DEBHELPER_COMPAT.')
+ unless defined $ENV{'DEFAULT_DEBHELPER_COMPAT'};
+ $testcase->store('Dh-Compat-Level', $ENV{'DEFAULT_DEBHELPER_COMPAT'})
+ unless $testcase->declares('Dh-Compat-Level');
+
+ # add additional version components
+ if ($testcase->declares('Version')) {
+
+ # add upstream version
+ my $upstream_version = $testcase->unfolded_value('Version');
+ $upstream_version =~ s/-[^-]+$//;
+ $upstream_version =~ s/(-|^)(\d+):/$1/;
+ $testcase->store('Upstream-Version', $upstream_version);
+
+ # version without epoch
+ my $no_epoch = $testcase->unfolded_value('Version');
+ $no_epoch =~ s/^\d+://;
+ $testcase->store('No-Epoch', $no_epoch);
+
+ unless ($testcase->declares('Prev-Version')) {
+ my $prev_version = '0.0.1';
+ $prev_version .= '-1'
+ unless $testcase->unfolded_value('Type') eq 'native';
+
+ $testcase->store('Prev-Version', $prev_version);
+ }
+ }
+
+ # calculate build dependencies
+ warn encode_utf8('Cannot override Build-Depends:')
+ if $testcase->declares('Build-Depends');
+ combine_fields($testcase, 'Build-Depends', $COMMA . $SPACE,
+ 'Default-Build-Depends', 'Extra-Build-Depends');
+
+ # calculate build conflicts
+ warn encode_utf8('Cannot override Build-Conflicts:')
+ if $testcase->declares('Build-Conflicts');
+ combine_fields($testcase, 'Build-Conflicts', $COMMA . $SPACE,
+ 'Default-Build-Conflicts', 'Extra-Build-Conflicts');
+
+ # fill testcase with itself; do it twice to make sure all is done
+ my $hashref = deb822_section_to_hash($testcase);
+ $hashref = fill_hash_from_hash($hashref);
+ $hashref = fill_hash_from_hash($hashref);
+ write_hash_to_deb822_section($hashref, $testcase);
+
+ say encode_utf8($EMPTY);
+
+ # fill remaining templates
+ fill_skeleton_templates($testcase->value('Fill-Targets'),
+ $hashref, $data_epoch, $sourcepath, $testset)
+ if $testcase->declares('Fill-Targets');
+
+ # write the dynamic file names
+ my $runfiles = path($sourcepath)->child('files');
+ write_config($files, $runfiles->stringify);
+
+ # set mtime for dynamic file names
+ $runfiles->touch($data_epoch);
+
+ # write the dynamic test case file
+ my $rundesc
+ = path($sourcepath)->child($files->unfolded_value('Fill-Values'));
+ write_config($testcase, $rundesc->stringify);
+
+ # set mtime for dynamic test data
+ $rundesc->touch($data_epoch);
+
+ say encode_utf8($EMPTY);
+
+ # announce data age
+ say encode_utf8('Data epoch is : '. rfc822date($data_epoch));
+
+ return;
+}
+
+=item filleval(SPEC_PATH, EVAL_PATH, TEST_SET, REBUILD)
+
+Populates a evaluation directory EVAL_PATH with data from the test located
+in SPEC_PATH. The optional parameter REBUILD forces a rebuild if true.
+
+=cut
+
+sub filleval {
+ my ($specpath, $evalpath, $testset, $force_rebuild)= @_;
+
+ say encode_utf8('------- Filling evaluation starts here -------');
+ say encode_utf8("Evaluation directory is $evalpath.");
+
+ # read defaults
+ my $defaultspath = "$testset/defaults";
+
+ # read default file names
+ my $defaultfilespath = "$defaultspath/files";
+ die encode_utf8("Cannot find $defaultfilespath")
+ unless -e $defaultfilespath;
+
+ # read file with default file names
+ my $files = read_config($defaultfilespath);
+
+ # read test data
+ my $descpath
+ = $specpath . $SLASH . $files->unfolded_value('Test-Specification');
+ my $desc = read_config($descpath);
+
+ # read test defaults
+ my $descdefaultspath
+ = $defaultspath . $SLASH . $files->unfolded_value('Test-Specification');
+ my $defaults = read_config($descdefaultspath);
+
+ # start with a shallow copy of defaults
+ my $testcase = Lintian::Deb822::Section->new;
+ $testcase->store($_, $defaults->value($_)) for $defaults->names;
+
+ die encode_utf8("Name missing for $specpath")
+ unless $desc->declares('Testname');
+
+ # delete old test scripts
+ my @oldrunners = File::Find::Rule->file->name('*.t')->in($evalpath);
+ if (@oldrunners) {
+ unlink(@oldrunners)
+ or die encode_utf8("Cannot unlink @oldrunners");
+ }
+
+ $testcase->store('Skeleton', $desc->value('Skeleton'))
+ unless $testcase->declares('Skeleton');
+
+ my $skeletonname = $testcase->unfolded_value('Skeleton');
+ if (length $skeletonname) {
+
+ # load skeleton
+ my $skeletonpath = "$testset/skeletons/$skeletonname";
+ my $skeleton = read_config($skeletonpath);
+
+ $testcase->store($_, $skeleton->value($_)) for $skeleton->names;
+ }
+
+ # add individual settings after skeleton
+ $testcase->store($_, $desc->value($_)) for $desc->names;
+
+ # populate working directory with specified template sets
+ copy_skeleton_template_sets($testcase->value('Template-Sets'),
+ $evalpath, $testset)
+ if $testcase->declares('Template-Sets');
+
+ # delete templates for which we have originals
+ remove_surplus_templates($specpath, $evalpath);
+
+ # copy test specification to working directory
+ my $offset = path($specpath)->relative($testset)->stringify;
+ say encode_utf8(
+ "Copy test specification $offset from $testset to $evalpath.");
+ copy_dir_contents($specpath, $evalpath);
+
+ my $valuefolder = $testcase->unfolded_value('Fill-Values-Folder');
+ if (length $valuefolder) {
+
+ # load all the values in the fill values folder
+ my $valuepath = "$evalpath/$valuefolder";
+ my @filepaths
+ = File::Find::Rule->file->name('*.values')->in($valuepath);
+
+ for my $filepath (sort @filepaths) {
+ my $fill_values = read_config($filepath);
+
+ $testcase->store($_, $fill_values->value($_))
+ for $fill_values->names;
+ }
+ }
+
+ # add individual settings after skeleton
+ $testcase->store($_, $desc->value($_)) for $desc->names;
+
+ # fill testcase with itself; do it twice to make sure all is done
+ my $hashref = deb822_section_to_hash($testcase);
+ $hashref = fill_hash_from_hash($hashref);
+ $hashref = fill_hash_from_hash($hashref);
+ write_hash_to_deb822_section($hashref, $testcase);
+
+ say encode_utf8($EMPTY);
+
+ # fill remaining templates
+ fill_skeleton_templates($testcase->value('Fill-Targets'),
+ $hashref, time, $evalpath, $testset)
+ if $testcase->declares('Fill-Targets');
+
+ # write the dynamic file names
+ my $runfiles = path($evalpath)->child('files');
+ write_config($files, $runfiles->stringify);
+
+ # write the dynamic test case file
+ my $rundesc
+ = path($evalpath)->child($files->unfolded_value('Test-Specification'));
+ write_config($testcase, $rundesc->stringify);
+
+ say encode_utf8($EMPTY);
+
+ return;
+}
+
+=item combine_fields
+
+=cut
+
+sub combine_fields {
+ my ($testcase, $destination, $delimiter, @sources) = @_;
+
+ return
+ unless length $destination;
+
+ # we are combining these contents
+ my @contents;
+ for my $source (@sources) {
+ push(@contents, $testcase->value($source))
+ if length $source;
+ $testcase->drop($source);
+ }
+
+ # combine
+ for my $content (@contents) {
+ $testcase->store(
+ $destination,
+ join($delimiter,
+ grep { length }($testcase->value($destination),$content))
+ );
+ }
+
+ # delete the combined entry if it is empty
+ $testcase->drop($destination)
+ unless length $testcase->value($destination);
+
+ return;
+}
+
+=item deb822_section_to_hash
+
+=cut
+
+sub deb822_section_to_hash {
+ my ($section) = @_;
+
+ my %hash;
+ for my $name ($section->names) {
+
+ my $transformed = lc $name;
+ $transformed =~ s/-/_/g;
+
+ $hash{$transformed} = $section->value($name);
+ }
+
+ return \%hash;
+}
+
+=item write_hash_to_deb822_section
+
+=cut
+
+sub write_hash_to_deb822_section {
+ my ($hashref, $section) = @_;
+
+ for my $name ($section->names) {
+
+ my $transformed = lc $name;
+ $transformed =~ s/-/_/g;
+
+ $section->store($name, $hashref->{$transformed});
+ }
+
+ return;
+}
+
+=item fill_hash_from_hash
+
+=cut
+
+sub fill_hash_from_hash {
+ my ($hashref, $delimiters) = @_;
+
+ $delimiters //= ['[%', '%]'];
+
+ my %origin = %{$hashref};
+ my %destination;
+
+ # fill hash with itself
+ for my $key (keys %origin) {
+
+ my $template = $origin{$key} // $EMPTY;
+ my $filler= Text::Template->new(TYPE => 'STRING', SOURCE => $template);
+ croak encode_utf8(
+ "Cannot read template $template: $Text::Template::ERROR")
+ unless $filler;
+
+ my $generated
+ = $filler->fill_in(HASH => \%origin, DELIMITERS => $delimiters);
+ croak encode_utf8("Could not create string from template $template")
+ unless defined $generated;
+ $destination{$key} = $generated;
+ }
+
+ return \%destination;
+}
+
+=back
+
+=head1 AUTHOR
+
+Originally written by Felix Lechner <felix.lechner@lease-up.com> for Lintian.
+
+=head1 SEE ALSO
+
+lintian(1)
+
+=cut
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
diff --git a/lib/Test/Lintian/Run.pm b/lib/Test/Lintian/Run.pm
new file mode 100644
index 0000000..4fb7c97
--- /dev/null
+++ b/lib/Test/Lintian/Run.pm
@@ -0,0 +1,570 @@
+# Copyright (C) 2018 Felix Lechner
+# Copyright (C) 2019 Chris Lamb <lamby@debian.org>
+#
+# 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
+
+package Test::Lintian::Run;
+
+=head1 NAME
+
+Test::Lintian::Run -- generic runner for all suites
+
+=head1 SYNOPSIS
+
+ use Test::Lintian::Run qw(runner);
+
+ my $runpath = "test working directory";
+
+ runner($runpath);
+
+=head1 DESCRIPTION
+
+Generic test runner for all Lintian test suites
+
+=cut
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Exporter qw(import);
+
+BEGIN {
+ our @EXPORT_OK = qw(
+ logged_runner
+ runner
+ check_result
+ );
+}
+
+use Capture::Tiny qw(capture_merged);
+use Const::Fast;
+use Cwd qw(getcwd);
+use File::Basename qw(basename);
+use File::Spec::Functions qw(abs2rel rel2abs splitpath catpath);
+use File::Compare;
+use File::Copy;
+use File::stat;
+use IPC::Run3;
+use List::Compare;
+use List::Util qw(max min any all);
+use Path::Tiny;
+use Syntax::Keyword::Try;
+use Test::More;
+use Text::Diff;
+use Unicode::UTF8 qw(encode_utf8 decode_utf8);
+
+use Lintian::Deb822;
+use Lintian::Profile;
+
+use Test::Lintian::ConfigFile qw(read_config);
+use Test::Lintian::Helper qw(rfc822date);
+use Test::Lintian::Hooks
+ qw(find_missing_prerequisites sed_hook sort_lines calibrate);
+use Test::Lintian::Output::Universal qw(get_tag_names order);
+
+const my $EMPTY => q{};
+const my $SPACE => q{ };
+const my $INDENT => $SPACE x 2;
+const my $SLASH => q{/};
+const my $NEWLINE => qq{\n};
+const my $YES => q{yes};
+const my $NO => q{no};
+
+const my $WAIT_STATUS_SHIFT => 8;
+
+# turn off the @@-style headers in Text::Diff
+no warnings 'redefine';
+sub Text::Diff::Unified::file_header { return $EMPTY; }
+sub Text::Diff::Unified::hunk_header { return $EMPTY; }
+
+=head1 FUNCTIONS
+
+=over 4
+
+=item logged_runner(RUN_PATH)
+
+Starts the generic test runner for the test located in RUN_PATH
+and logs the output.
+
+=cut
+
+sub logged_runner {
+ my ($runpath) = @_;
+
+ my $error;
+
+ # read dynamic file names
+ my $runfiles = "$runpath/files";
+ my $files = read_config($runfiles);
+
+ # set path to logfile
+ my $logpath = $runpath . $SLASH . $files->unfolded_value('Log');
+
+ my $log_bytes = capture_merged {
+ try {
+ # call runner
+ runner($runpath, $logpath)
+
+ } catch {
+ # catch any error
+ $error = $@;
+ }
+ };
+
+ my $log = decode_utf8($log_bytes);
+
+ # append runner log to population log
+ path($logpath)->append_utf8($log) if length $log;
+
+ # add error if there was one
+ path($logpath)->append_utf8($error) if length $error;
+
+ # print log and die on error
+ if ($error) {
+ print encode_utf8($log)
+ if length $log && $ENV{'DUMP_LOGS'}//$NO eq $YES;
+ die encode_utf8("Runner died for $runpath: $error");
+ }
+
+ return;
+}
+
+=item runner(RUN_PATH)
+
+This routine provides the basic structure for all runners and runs the
+test located in RUN_PATH.
+
+=cut
+
+sub runner {
+ my ($runpath, @exclude)= @_;
+
+ # set a predictable locale
+ $ENV{'LC_ALL'} = 'C';
+
+ say encode_utf8($EMPTY);
+ say encode_utf8('------- Runner starts here -------');
+
+ # bail out if runpath does not exist
+ BAIL_OUT(encode_utf8("Cannot find test directory $runpath."))
+ unless -d $runpath;
+
+ # announce location
+ say encode_utf8("Running test at $runpath.");
+
+ # read dynamic file names
+ my $runfiles = "$runpath/files";
+ my $files = read_config($runfiles);
+
+ # get file age
+ my $spec_epoch = stat($runfiles)->mtime;
+
+ # read dynamic case data
+ my $rundescpath
+ = $runpath . $SLASH . $files->unfolded_value('Test-Specification');
+ my $testcase = read_config($rundescpath);
+
+ # get data age
+ $spec_epoch = max(stat($rundescpath)->mtime, $spec_epoch);
+ say encode_utf8('Specification is from : '. rfc822date($spec_epoch));
+
+ say encode_utf8($EMPTY);
+
+ # age of runner executable
+ my $runner_epoch = $ENV{'RUNNER_EPOCH'}//time;
+ say encode_utf8('Runner modified on : '. rfc822date($runner_epoch));
+
+ # age of harness executable
+ my $harness_epoch = $ENV{'HARNESS_EPOCH'}//time;
+ say encode_utf8('Harness modified on : '. rfc822date($harness_epoch));
+
+ # calculate rebuild threshold
+ my $threshold= max($spec_epoch, $runner_epoch, $harness_epoch);
+ say encode_utf8('Rebuild threshold is : '. rfc822date($threshold));
+
+ say encode_utf8($EMPTY);
+
+ # age of Lintian executable
+ my $lintian_epoch = $ENV{'LINTIAN_EPOCH'}//time;
+ say encode_utf8('Lintian modified on : '. rfc822date($lintian_epoch));
+
+ my $testname = $testcase->unfolded_value('Testname');
+ # name of encapsulating directory should be that of test
+ my $expected_name = path($runpath)->basename;
+ die encode_utf8(
+ "Test in $runpath is called $testname instead of $expected_name")
+ unless $testname eq $expected_name;
+
+ # skip test if marked
+ my $skipfile = "$runpath/skip";
+ if (-e $skipfile) {
+ my $reason = path($skipfile)->slurp_utf8 || 'No reason given';
+ say encode_utf8("Skipping test: $reason");
+ plan skip_all => "(disabled) $reason";
+ }
+
+ # skip if missing prerequisites
+ my $missing = find_missing_prerequisites($testcase);
+ if (length $missing) {
+ say encode_utf8("Missing prerequisites: $missing");
+ plan skip_all => $missing;
+ }
+
+ # check test architectures
+ unless (length $ENV{'DEB_HOST_ARCH'}) {
+ say encode_utf8('DEB_HOST_ARCH is not set.');
+ BAIL_OUT(encode_utf8('DEB_HOST_ARCH is not set.'));
+ }
+ my $platforms = $testcase->unfolded_value('Test-Architectures');
+ if ($platforms ne 'any') {
+
+ my @wildcards = split($SPACE, $platforms);
+ my $match = 0;
+ for my $wildcard (@wildcards) {
+
+ my @command = (
+ qw{dpkg-architecture -a},
+ $ENV{'DEB_HOST_ARCH'}, '-i', $wildcard
+ );
+ run3(\@command, \undef, \undef, \undef);
+ my $status = ($? >> $WAIT_STATUS_SHIFT);
+
+ unless ($status) {
+ $match = 1;
+ last;
+ }
+ }
+ unless ($match) {
+ say encode_utf8('Architecture mismatch');
+ plan skip_all => encode_utf8('Architecture mismatch');
+ }
+ }
+
+ plan skip_all => 'No package found'
+ unless -e "$runpath/subject";
+
+ # set the testing plan
+ plan tests => 1;
+
+ my $subject = path("$runpath/subject")->realpath;
+
+ # get lintian subject
+ die encode_utf8('Could not get subject of Lintian examination.')
+ unless -e $subject;
+
+ # run lintian
+ $ENV{'LINTIAN_COVERAGE'}.= ",-db,./cover_db-$testname"
+ if exists $ENV{'LINTIAN_COVERAGE'};
+
+ my $lintian_command_line
+ = $testcase->unfolded_value('Lintian-Command-Line');
+ my $command
+ = "cd $runpath; $ENV{'LINTIAN_UNDER_TEST'} $lintian_command_line $subject";
+ say encode_utf8($command);
+ my ($output, $status) = capture_merged { system($command); };
+ $status >>= $WAIT_STATUS_SHIFT;
+
+ $output = decode_utf8($output)
+ if length $output;
+
+ say encode_utf8("$command exited with status $status.");
+ say encode_utf8($output) if $status == 1;
+
+ my $expected_status = $testcase->unfolded_value('Exit-Status');
+
+ my @errors;
+ push(@errors,
+ "Exit code $status differs from expected value $expected_status.")
+ if $testcase->declares('Exit-Status')
+ && $status != $expected_status;
+
+ # filter out some warnings if running under coverage
+ my @lines = split(/\n/, $output);
+ if (exists $ENV{LINTIAN_COVERAGE}) {
+ # Devel::Cover causes deep recursion warnings.
+ @lines = grep {
+ !m{^Deep [ ] recursion [ ] on [ ] subroutine [ ]
+ "[^"]+" [ ] at [ ] .*B/Deparse.pm [ ] line [ ]
+ \d+}xsm
+ } @lines;
+ }
+
+ # put output back together
+ $output = $EMPTY;
+ $output .= $_ . $NEWLINE for @lines;
+
+ die encode_utf8('No match strategy defined')
+ unless $testcase->declares('Match-Strategy');
+
+ my $match_strategy = $testcase->unfolded_value('Match-Strategy');
+
+ if ($match_strategy eq 'literal') {
+ push(@errors, check_literal($testcase, $runpath, $output));
+
+ } elsif ($match_strategy eq 'hints') {
+ push(@errors, check_hints($testcase, $runpath, $output));
+
+ } else {
+ die encode_utf8("Unknown match strategy $match_strategy.");
+ }
+
+ my $okay = !(scalar @errors);
+
+ if ($testcase->declares('Todo')) {
+
+ my $explanation = $testcase->unfolded_value('Todo');
+ diag encode_utf8("TODO ($explanation)");
+
+ TODO: {
+ local $TODO = $explanation;
+ ok($okay, 'Lintian passes for test marked TODO.');
+ }
+
+ return;
+ }
+
+ diag encode_utf8($_ . $NEWLINE) for @errors;
+
+ ok($okay, "Lintian passes for $testname");
+
+ return;
+}
+
+=item check_literal
+
+=cut
+
+sub check_literal {
+ my ($testcase, $runpath, $output) = @_;
+
+ # create expected output if it does not exist
+ my $expected = "$runpath/literal";
+ path($expected)->touch
+ unless -e $expected;
+
+ my $raw = "$runpath/literal.actual";
+ path($raw)->spew_utf8($output);
+
+ # run a sed-script if it exists
+ my $actual = "$runpath/literal.actual.parsed";
+ my $script = "$runpath/post-test";
+ if (-e $script) {
+ sed_hook($script, $raw, $actual);
+ } else {
+ die encode_utf8("Could not copy actual hints $raw to $actual: $!")
+ if system('cp', '-p', $raw, $actual);
+ }
+
+ return check_result($testcase, $runpath, $expected, $actual);
+}
+
+=item check_hints
+
+=cut
+
+sub check_hints {
+ my ($testcase, $runpath, $output) = @_;
+
+ # create expected hints if there are none; helps when calibrating new tests
+ my $expected = "$runpath/hints";
+ path($expected)->touch
+ unless -e $expected;
+
+ my $raw = "$runpath/hints.actual";
+ path($raw)->spew_utf8($output);
+
+ # run a sed-script if it exists
+ my $actual = "$runpath/hints.actual.parsed";
+ my $sedscript = "$runpath/post-test";
+ if (-e $sedscript) {
+ sed_hook($sedscript, $raw, $actual);
+ } else {
+ die encode_utf8("Could not copy actual hints $raw to $actual: $!")
+ if system('cp', '-p', $raw, $actual);
+ }
+
+ # calibrate hints; may write to $actual
+ my $calibrated = "$runpath/hints.specified.calibrated";
+ my $calscript = "$runpath/test-calibration";
+ if(-x $calscript) {
+ calibrate($calscript, $actual, $expected, $calibrated);
+ } else {
+ die encode_utf8(
+ "Could not copy expected hints $expected to $calibrated: $!")
+ if system('cp', '-p', $expected, $calibrated);
+ }
+
+ return check_result($testcase, $runpath, $calibrated, $actual);
+}
+
+=item check_result(DESC, EXPECTED, ACTUAL)
+
+This routine checks if the EXPECTED hints match the calibrated ACTUAL for the
+test described by DESC. For some additional checks, also need the ORIGINAL
+hints before calibration. Returns a list of errors, if there are any.
+
+=cut
+
+sub check_result {
+ my ($testcase, $runpath, $expectedpath, $actualpath) = @_;
+
+ my @errors;
+
+ my @expectedlines = path($expectedpath)->lines_utf8;
+ my @actuallines = path($actualpath)->lines_utf8;
+
+ push(@expectedlines, $NEWLINE)
+ unless @expectedlines;
+ push(@actuallines, $NEWLINE)
+ unless @actuallines;
+
+ my $match_strategy = $testcase->unfolded_value('Match-Strategy');
+
+ if ($match_strategy eq 'hints') {
+ @expectedlines
+ = reverse sort { order($a) cmp order($b) } @expectedlines;
+ @actuallines
+ = reverse sort { order($a) cmp order($b) } @actuallines;
+ }
+
+ my $diff = diff(\@expectedlines, \@actuallines, { CONTEXT => 0 });
+ my @difflines = split(/\n/, $diff);
+ chomp @difflines;
+
+ # diag encode_utf8("Difflines: $_") for @difflines;
+
+ if(@difflines) {
+
+ if ($match_strategy eq 'literal') {
+ push(@errors, 'Literal output does not match');
+
+ } elsif ($match_strategy eq 'hints') {
+
+ push(@errors, 'Hints do not match');
+
+ @difflines = reverse sort @difflines;
+ my $hintdiff;
+ $hintdiff .= $_ . $NEWLINE for @difflines;
+ path("$runpath/hintdiff")->spew_utf8($hintdiff // $EMPTY);
+
+ } else {
+ die encode_utf8("Unknown match strategy $match_strategy.");
+ }
+
+ push(@errors, $EMPTY);
+
+ push(@errors, '--- ' . abs2rel($expectedpath));
+ push(@errors, '+++ ' . abs2rel($actualpath));
+ push(@errors, @difflines);
+
+ push(@errors, $EMPTY);
+ }
+
+ # stop if the test is not about hints
+ return @errors
+ unless $match_strategy eq 'hints';
+
+ # get expected tags
+ my @expected = sort +get_tag_names($expectedpath);
+
+ #diag encode_utf8("=Expected tag: $_") for @expected;
+
+ # look out for tags being tested
+ my @related;
+
+ if ( $testcase->declares('Check')
+ && $testcase->unfolded_value('Check') ne 'all') {
+
+ my $profile = Lintian::Profile->new;
+ $profile->load(undef, undef, 0);
+
+ # use tags related to checks declared
+ my @check_names = $testcase->trimmed_list('Check');
+ my @unknown
+ = grep { !exists $profile->check_module_by_name->{$_} } @check_names;
+
+ die encode_utf8('Unknown Lintian checks: ' . join($SPACE, @unknown))
+ if @unknown;
+
+ push(@related, @{$profile->tag_names_for_check->{$_} // []})
+ for @check_names;
+
+ @related = sort @related;
+
+ } else {
+ # otherwise, look for all expected tags
+ @related = @expected;
+ }
+
+ #diag encode_utf8("#Related tag: $_") for @related;
+
+ # calculate Test-For and Test-Against; results are sorted
+ my $material = List::Compare->new(\@expected, \@related);
+ my @test_for = $material->get_intersection;
+ my @test_against = $material->get_Ronly;
+
+ #diag encode_utf8("+Test-For: $_") for @test_for;
+ #diag encode_utf8("-Test-Against (calculated): $_") for @test_against;
+
+ # get actual tags from output
+ my @actual = sort +get_tag_names($actualpath);
+
+ #diag encode_utf8("*Actual tag found: $_") for @actual;
+
+ # check for blacklisted tags; result is sorted
+ my @unexpected
+ = List::Compare->new(\@test_against, \@actual)->get_intersection;
+
+ # warn about unexpected tags
+ if (@unexpected) {
+ push(@errors, 'Unexpected tags:');
+ push(@errors, $INDENT . $_) for @unexpected;
+ push(@errors, $EMPTY);
+ }
+ # find tags not seen; result is sorted
+ my @missing = List::Compare->new(\@test_for, \@actual)->get_Lonly;
+
+ # warn about missing tags
+ if (@missing) {
+ push(@errors, 'Missing tags:');
+ push(@errors, $INDENT . $_) for @missing;
+ push(@errors, $EMPTY);
+ }
+
+ return @errors;
+}
+
+=back
+
+=head1 AUTHOR
+
+Originally written by Felix Lechner <felix.lechner@lease-up.com> for Lintian.
+
+=head1 SEE ALSO
+
+lintian(1)
+
+=cut
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
diff --git a/lib/Test/Lintian/Templates.pm b/lib/Test/Lintian/Templates.pm
new file mode 100644
index 0000000..b52df15
--- /dev/null
+++ b/lib/Test/Lintian/Templates.pm
@@ -0,0 +1,348 @@
+# Copyright (C) 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 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
+
+package Test::Lintian::Templates;
+
+=head1 NAME
+
+Test::Lintian::Templates -- Helper routines dealing with templates
+
+=head1 SYNOPSIS
+
+use Test::Lintian::Templates qw(fill_template);
+
+my $data = { 'placeholder' => 'value' };
+my $file = '/path/to/generated/file';
+
+fill_template("$file.in", $file, $data);
+
+=head1 DESCRIPTION
+
+Routines for dealing with templates in Lintian test specifications.
+
+=cut
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Exporter qw(import);
+
+BEGIN {
+ our @EXPORT_OK = qw(
+ copy_skeleton_template_sets
+ remove_surplus_templates
+ fill_skeleton_templates
+ fill_whitelisted_templates
+ fill_all_templates
+ fill_template
+ );
+}
+
+use Carp;
+use Const::Fast;
+use List::Util qw(max);
+use File::Path qw(make_path);
+use File::Spec::Functions qw(rel2abs abs2rel);
+use File::Find::Rule;
+use File::stat;
+use Path::Tiny;
+use Text::Template;
+use Unicode::UTF8 qw(encode_utf8);
+
+use Test::Lintian::ConfigFile qw(read_config);
+use Test::Lintian::Helper qw(copy_dir_contents);
+
+const my $EMPTY => q{};
+const my $SPACE => q{ };
+const my $DOT => q{.};
+const my $COMMA => q{,};
+const my $COLON => q{:};
+
+=head1 FUNCTIONS
+
+=over 4
+
+=item copy_skeleton_template_sets(INSTRUCTIONS, RUN_PATH, SUITE, TEST_SET)
+
+Copies template sets belonging to SUITE into the test working directory
+RUN_PATH according to INSTRUCTIONS. The INSTRUCTIONS are the target
+directory relative to RUN_PATH followed by the name of the template set
+in parentheses. Multiple such instructions must be separated by commas.
+
+=cut
+
+sub copy_skeleton_template_sets {
+ my ($instructions, $runpath, $testset)= @_;
+
+ # populate working directory with specified template sets
+ for my $placement (split($COMMA, $instructions)) {
+
+ my ($relative, $name)
+ =($placement =~ qr/^\s*([^()\s]+)\s*\(([^()\s]+)\)\s*$/);
+
+ croak encode_utf8('No template destination specified in skeleton.')
+ unless length $relative;
+
+ croak encode_utf8('No template set specified in skeleton.')
+ unless length $name;
+
+ my $templatesetpath = "$testset/templates/$name";
+ croak encode_utf8(
+ "Cannot find template set '$name' at $templatesetpath.")
+ unless -d $templatesetpath;
+
+ say encode_utf8(
+ "Installing template set '$name'"
+ . (
+ $relative ne $DOT ? " to ./$relative." : $EMPTY
+ )
+ );
+
+ # create directory
+ my $destination = "$runpath/$relative";
+ make_path($destination);
+
+ # copy template set
+ copy_dir_contents($templatesetpath, $destination)
+ if -d $templatesetpath;
+ }
+ return;
+}
+
+=item remove_surplus_templates(SRC_DIR, TARGET_DIR)
+
+Removes from TARGET_DIR any templates that have corresponding originals
+in SRC_DIR.
+
+=cut
+
+sub remove_surplus_templates {
+ my ($source, $destination) = @_;
+
+ my @originals = File::Find::Rule->file->in($source);
+ foreach my $original (@originals) {
+ my $relative = abs2rel($original, $source);
+ my $template = rel2abs("$relative.in", $destination);
+
+ if (-e $template) {
+ unlink($template)
+ or die encode_utf8("Cannot unlink $template");
+ }
+ }
+ return;
+}
+
+=item fill_skeleton_templates(INSTRUCTIONS, HASH, EPOCH, RUN_PATH, TEST_SET)
+
+Fills the templates specified in INSTRUCTIONS using the data in HASH. Only
+fills templates when the generated files are not present or are older than
+either the file modification time of the template or the age of the data
+as evidenced by EPOCH. The INSTRUCTIONS are the target directory relative
+to RUN_PATH followed by the name of the whitelist in parentheses. Multiple
+instructions must be separated by commas.
+
+=cut
+
+sub fill_skeleton_templates {
+ my ($instructions, $testcase, $threshold, $runpath, $testset)= @_;
+
+ for my $target (split(/$COMMA/, $instructions)) {
+
+ my ($relative, $name)
+ =($target=~ qr/^\s*([^()\s]+)\s*(?:\(([^()\s]+)\))?\s*$/);
+
+ croak encode_utf8('No fill destination specified in skeleton.')
+ unless length $relative;
+
+ if (length $name) {
+
+ # template set
+ my $whitelistpath = "$testset/whitelists/$name";
+ croak encode_utf8(
+ "Cannot find template whitelist '$name' at $whitelistpath")
+ unless -e $whitelistpath;
+
+ say encode_utf8($EMPTY);
+
+ say encode_utf8(
+ 'Generate files '
+ . (
+ $relative ne $DOT ? "in ./$relative " : $EMPTY
+ )
+ . "from templates using whitelist '$name'."
+ );
+ my $whitelist = read_config($whitelistpath);
+
+ my @candidates = $whitelist->trimmed_list('May-Generate');
+ my $destination = "$runpath/$relative";
+
+ say encode_utf8(
+ 'Fill templates'
+ . (
+ $relative ne $DOT ? " in ./$relative" : $EMPTY
+ )
+ . $COLON
+ . $SPACE
+ . join($SPACE, @candidates)
+ );
+
+ foreach my $candidate (@candidates) {
+ my $generated = rel2abs($candidate, $destination);
+ my $template = "$generated.in";
+
+ # fill template if needed
+ fill_template($template, $generated, $testcase, $threshold)
+ if -e $template;
+ }
+
+ }else {
+
+ # single file
+ say encode_utf8("Filling template: $relative");
+
+ my $generated = rel2abs($relative, $runpath);
+ my $template = "$generated.in";
+
+ # fill template if needed
+ fill_template($template, $generated, $testcase, $threshold)
+ if -e $template;
+ }
+ }
+ return;
+}
+
+=item fill_whitelisted_templates(DIR, WHITE_LIST, HASH, HASH_EPOCH)
+
+Generates all files in array WHITE_LIST relative to DIR from their templates,
+which are assumed to have the same file name but with extension '.in', using
+data provided in HASH. The optional argument HASH_EPOCH can be used to
+preserve files when no generation is necessary.
+
+=cut
+
+sub fill_whitelisted_templates {
+ my ($directory, $whitelistpath, $data, $data_epoch) = @_;
+
+ croak encode_utf8("No whitelist found at $whitelistpath")
+ unless -e $whitelistpath;
+
+ my $whitelist = read_config($whitelistpath);
+ my @list = $whitelist->trimmed_list('May-Generate');
+
+ foreach my $file (@list) {
+ my $generated = rel2abs($file, $directory);
+ my $template = "$generated.in";
+
+ # fill template if needed
+ fill_template($template, $generated, $data, $data_epoch)
+ if -e $template;
+ }
+ return;
+}
+
+=item fill_all_templates(HASH, DIR)
+
+Fills all templates in DIR with data from HASH.
+
+=cut
+
+sub fill_all_templates {
+ my ($data, $data_epoch, $directory) = @_;
+
+ my @templates = File::Find::Rule->name('*.in')->in($directory);
+ foreach my $template (@templates) {
+ my ($generated) = ($template =~ qr/^(.+?)\.in$/);
+
+ # fill template if needed
+ fill_template($template, $generated, $data, $data_epoch);
+ }
+ return;
+}
+
+=item fill_template(TEMPLATE, GENERATED, HASH, HASH_EPOCH, DELIMITERS)
+
+Fills template TEMPLATE with data from HASH and places the result in
+file GENERATED. When given HASH_EPOCH, will evaluate beforehand if a
+substitution is necessary based on file modification times. The optional
+parameter DELIMITERS can be used to change the standard delimiters.
+
+=cut
+
+sub fill_template {
+ my ($template, $generated, $data, $data_epoch, $delimiters) = @_;
+
+ my $generated_epoch
+ = length $generated && -e $generated ? stat($generated)->mtime : 0;
+ my $template_epoch
+ = length $template && -e $template ? stat($template)->mtime : time;
+ my $threshold = max($template_epoch, $data_epoch//time);
+
+ if ($generated_epoch <= $threshold) {
+
+ my $filler= Text::Template->new(
+ TYPE => 'FILE',
+ DELIMITERS => ['[%', '%]'],
+ SOURCE => $template
+ );
+ croak encode_utf8(
+ "Cannot read template $template: $Text::Template::ERROR")
+ unless $filler;
+
+ open(my $handle, '>', $generated)
+ or croak encode_utf8("Could not open file $generated: $!");
+ $filler->fill_in(
+ OUTPUT => $handle,
+ HASH => $data,
+ DELIMITERS => $delimiters
+ )
+ or croak encode_utf8(
+ "Could not create file $generated from template $template");
+ close $handle
+ or carp encode_utf8("Could not close file $generated: $!");
+
+ # transfer file permissions from template to generated file
+ my $stat = stat($template)
+ or croak encode_utf8("stat $template failed: $!");
+ chmod $stat->mode, $generated
+ or croak encode_utf8("chmod $generated failed: $!");
+
+ # set mtime to $threshold
+ path($generated)->touch($threshold);
+ }
+
+ # delete template
+ if (-e $generated) {
+ unlink($template)
+ or die encode_utf8("Cannot unlink $template");
+ }
+
+ return;
+}
+
+=back
+
+=cut
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
diff --git a/lib/Test/ScriptAge.pm b/lib/Test/ScriptAge.pm
new file mode 100644
index 0000000..dcab63b
--- /dev/null
+++ b/lib/Test/ScriptAge.pm
@@ -0,0 +1,109 @@
+# Copyright (C) 2019 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
+
+package Test::ScriptAge;
+
+=head1 NAME
+
+Test::ScriptAge -- routines relating to the age of Perl scripts
+
+=head1 SYNOPSIS
+
+ my $executable_epoch = Test::ScriptAge::our_modification_epoch();
+ print encode_utf8('This script was last modified at ' . localtime($executable_epoch) . "\n");
+
+ my $perl_epoch = Test::ScriptAge::perl_modification_epoch();
+ print encode_utf8('Perl was last modified at ' . localtime($perl_epoch) . "\n");
+
+=head1 DESCRIPTION
+
+Routines to calculated modification times of Perl scripts.
+
+=cut
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Exporter qw(import);
+
+BEGIN {
+ our @EXPORT_OK = qw(
+ perl_modification_epoch
+ our_modification_epoch
+ );
+}
+
+use File::stat;
+use File::Spec::Functions qw(rel2abs);
+use List::Util qw(max);
+use Path::Tiny;
+use Unicode::UTF8 qw(encode_utf8);
+
+=head1 FUNCTIONS
+
+=over 4
+
+=item perl_modification_epoch
+
+Calculate the time our Perl was last modified.
+
+=cut
+
+sub perl_modification_epoch {
+ my $perlpath = rel2abs($^X);
+ return stat($perlpath)->mtime;
+}
+
+=item our_modification_epoch
+
+Calculate the time our scripts, including all libraries, was last modified.
+
+=cut
+
+sub our_modification_epoch {
+ my (undef, $callerpath, undef) = caller;
+
+ my @paths = map { rel2abs($_) } ($callerpath, values %INC);
+ if (my @relative = grep { !/^\// } @paths){
+ warn encode_utf8(
+ 'Relative paths in running_epoch: '.join(', ', @relative));
+ }
+ my @epochs = map { path($_)->stat->mtime } @paths;
+ return max @epochs;
+}
+
+=back
+
+=head1 AUTHOR
+
+Originally written by Felix Lechner <felix.lechner@lease-up.com> for Lintian.
+
+=head1 SEE ALSO
+
+lintian(1)
+
+=cut
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
diff --git a/lib/Test/StagedFileProducer.pm b/lib/Test/StagedFileProducer.pm
new file mode 100644
index 0000000..ada9069
--- /dev/null
+++ b/lib/Test/StagedFileProducer.pm
@@ -0,0 +1,314 @@
+# Copyright (C) 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 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
+
+package Test::StagedFileProducer;
+
+=head1 NAME
+
+Test::StagedFileProducer -- mtime-based file production engine
+
+=head1 SYNOPSIS
+
+ use Test::StagedFileProducer;
+
+ my $wherever = '/your/test/directory';
+
+ my $producer = Test::StagedFileProducer->new(path => $wherever);
+ $producer->exclude("$wherever/log", "$wherever/build-stamp");
+
+ my $output = "$wherever/file.out";
+ $producer->add_stage(
+ products => [$output],
+ build =>sub {
+ print encode_utf8("Building $output.\n");
+ },
+ skip =>sub {
+ print encode_utf8("Skipping $output.\n");
+ }
+ );
+
+ $producer->run(minimum_epoch => time, verbose => 1);
+
+=head1 DESCRIPTION
+
+Provides a way to define and stack file production stages that all
+depend on subsets of the same group of files.
+
+After the stages are defined, the processing engine takes an inventory
+of all files in a target directory. It excludes some files, like logs,
+that should not be considered.
+
+Each stage adds its own products to the list of files to be excluded
+before deciding whether to produce them. The decision is based on
+relative file modification times, in addition to a systemic rebuilding
+threshold. Before rebuilding, each stage asks a lower stage to make
+the same determination.
+
+The result is an engine with file production stages that depend on
+successively larger sets of files.
+
+=cut
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Carp;
+use Const::Fast;
+use File::Find::Rule;
+use File::Spec::Functions qw(abs2rel);
+use File::stat;
+use List::Util qw(min max);
+use Path::Tiny;
+use Unicode::UTF8 qw(encode_utf8);
+
+use Test::Lintian::Helper qw(rfc822date);
+
+const my $EMPTY => q{};
+const my $SPACE => q{ };
+
+=head1 FUNCTIONS
+
+=over 4
+
+=item new(path => PATH)
+
+Create a new instance focused on files in directory PATH.
+
+=cut
+
+sub new {
+ my ($class, %params) = @_;
+
+ my $self = bless {}, $class;
+
+ croak encode_utf8('Cannot proceed without a path.')
+ unless exists $params{path};
+ $self->{path} = $params{path};
+
+ $self->{exclude} = [];
+ $self->{stages} = [];
+
+ return $self;
+}
+
+=item exclude(LIST)
+
+Excludes all absolute paths in LIST from all mtime comparisons.
+This is especially useful for logs. Calls to Path::Tiny->realpath
+are made to ensure the elements are canonical and have a chance
+of matching something returned by File::Find::Rule.
+
+=cut
+
+sub exclude {
+ my ($self, @list) = @_;
+
+ push(@{$self->{exclude}}, grep { defined } @list);
+
+ return;
+}
+
+=item add_stage(HASH)
+
+Add a stage defined by HASH to the processing engine for processing
+after stages previously added. HASH can define the following keys:
+
+$HASH{products} => LIST; a list of full-path filenames to be
+produced.
+
+$HASH{minimum_epoch} => EPOCH; an integer threshold for maximum age
+
+$HASH{build} => SUB; a sub executed when production is required.
+
+$HASH{skip} => SUB; a sub executed when production is not required.
+
+=cut
+
+sub add_stage {
+ my ($self, %stage) = @_;
+
+ push(@{$self->{stages}}, \%stage);
+
+ return;
+}
+
+=item run(PARAMETERS)
+
+Runs the defined engine using the given parameters, which are
+arranged in a matching list suitable for assignment to a hash.
+The following two parameters are currently available:
+
+minimum_epoch => EPOCH; a systemic threshold, in epochs, below
+which rebuilding is mandatory for any product.
+
+verbose => BOOLEAN; an option to enable more verbose reporting
+
+=cut
+
+sub run {
+ my ($self, %params) = @_;
+
+ $self->{minimum_epoch} = $params{minimum_epoch} // 0;
+ $self->{verbose} = $params{verbose} // 0;
+
+ # take an mtime inventory of all files in path
+ $self->{mtimes}
+ = { map { $_ => path($_)->stat->mtime }
+ File::Find::Rule->file->in($self->{path}) };
+
+ say encode_utf8(
+ 'Found the following file modification times (most recent first):')
+ if $self->{verbose};
+
+ my @ordered= reverse sort { $self->{mtimes}{$a} <=> $self->{mtimes}{$b} }
+ keys %{$self->{mtimes}};
+ foreach my $file (@ordered) {
+ my $relative = abs2rel($file, $self->{path});
+ say encode_utf8(rfc822date($self->{mtimes}{$file}) . " : $relative")
+ if $self->{verbose};
+ }
+
+ $self->_process_remaining_stages(@{$self->{exclude}});
+
+ return;
+}
+
+=item _process_remaining_stages(LIST)
+
+An internal subroutine that is used recursively to execute
+the stages. The list passed describes the list of files to
+be excluded from subsequent mtime calculations.
+
+Please note that the bulk of the execution takes place
+after calling the next lower stage. That is to ensure that
+any lower build targets (or products, in our parlance) are
+met before the present stage attempts to do its job.
+
+=cut
+
+sub _process_remaining_stages {
+ my ($self, @exclude) = @_;
+
+ if (scalar @{$self->{stages}}) {
+
+ # get the next processing stage
+ my %stage = %{ pop(@{$self->{stages}}) };
+
+ # add our products to the list of files excluded
+ my @products = grep { defined } @{$stage{products}//[]};
+ push(@exclude, @products);
+
+ # pass to next lower stage for potential rebuilding
+ $self->_process_remaining_stages(@exclude);
+
+ # get good paths that will match those of File::Find
+ @exclude = map { path($_)->realpath } @exclude;
+
+ say encode_utf8($EMPTY) if $self->{verbose};
+
+ my @relative = sort map { abs2rel($_, $self->{path}) } @products;
+ say encode_utf8(
+ 'Considering production of: ' . join($SPACE, @relative))
+ if $self->{verbose};
+
+ say encode_utf8('Excluding: '
+ . join($SPACE, sort map { abs2rel($_, $self->{path}) } @exclude))
+ if $self->{verbose};
+
+ my %relevant = %{$self->{mtimes}};
+ delete @relevant{@exclude};
+
+# my @ordered= reverse sort { $relevant{$a} <=> $relevant{$b} }
+# keys %relevant;
+# foreach my $file (@ordered) {
+# say encode_utf8(rfc822date($relevant{$file}) . ' : ' . abs2rel($file, $self->{path}))
+# if $self->{verbose};
+# }
+
+ say encode_utf8($EMPTY) if $self->{verbose};
+
+ my $file_epoch = (max(values %relevant))//time;
+ say encode_utf8(
+ 'Input files modified on : '. rfc822date($file_epoch))
+ if $self->{verbose};
+
+ my $systemic_minimum_epoch = $self->{minimum_epoch} // 0;
+ say encode_utf8('Systemic minimum epoch is : '
+ . rfc822date($systemic_minimum_epoch))
+ if $self->{verbose};
+
+ my $stage_minimum_epoch = $stage{minimum_epoch} // 0;
+ say encode_utf8('Stage minimum epoch is : '
+ . rfc822date($stage_minimum_epoch))
+ if $self->{verbose};
+
+ my $threshold
+ = max($stage_minimum_epoch, $systemic_minimum_epoch, $file_epoch);
+ say encode_utf8(
+ 'Rebuild threshold is : '. rfc822date($threshold))
+ if $self->{verbose};
+
+ say encode_utf8($EMPTY) if $self->{verbose};
+
+ my $product_epoch
+ = min(map { -e ? path($_)->stat->mtime : 0 } @products);
+ if($product_epoch) {
+ say encode_utf8(
+ 'Products modified on : '. rfc822date($product_epoch))
+ if $self->{verbose};
+ } else {
+ say encode_utf8('At least one product is not present.')
+ if $self->{verbose};
+ }
+
+ # not producing if times are equal; resolution 1 sec
+ if ($product_epoch < $threshold) {
+
+ say encode_utf8('Producing: ' . join($SPACE, @relative))
+ if $self->{verbose};
+
+ $stage{build}->() if exists $stage{build};
+
+ # sometimes the products are not the newest files
+ path($_)->touch(time) for @products;
+
+ } else {
+
+ say encode_utf8(
+ 'Skipping production of: ' . join($SPACE, @relative))
+ if $self->{verbose};
+
+ $stage{skip}->() if exists $stage{skip};
+ }
+ }
+
+ return;
+}
+
+=back
+
+=cut
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
generated by cgit v1.2.3 (git 2.39.1) at 2024-11-04 07:29:52 +0000