diff options
Diffstat (limited to '')
| -rw-r--r-- | lib/Test/Lintian.pm | 697 | ||||
| -rw-r--r-- | lib/Test/Lintian/Build.pm | 163 | ||||
| -rw-r--r-- | lib/Test/Lintian/ConfigFile.pm | 132 | ||||
| -rw-r--r-- | lib/Test/Lintian/Filter.pm | 378 | ||||
| -rw-r--r-- | lib/Test/Lintian/Helper.pm | 198 | ||||
| -rw-r--r-- | lib/Test/Lintian/Hooks.pm | 228 | ||||
| -rw-r--r-- | lib/Test/Lintian/Output/EWI.pm | 117 | ||||
| -rw-r--r-- | lib/Test/Lintian/Output/Universal.pm | 189 | ||||
| -rw-r--r-- | lib/Test/Lintian/Prepare.pm | 551 | ||||
| -rw-r--r-- | lib/Test/Lintian/Run.pm | 570 | ||||
| -rw-r--r-- | lib/Test/Lintian/Templates.pm | 348 |
11 files changed, 3571 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 |