summaryrefslogtreecommitdiffstats
path: root/lib/Lintian/Check/Debian
diff options
context:
space:
mode:
Diffstat (limited to '')
-rw-r--r--lib/Lintian/Check/Debian/Changelog.pm970
-rw-r--r--lib/Lintian/Check/Debian/Control/Field/Adopted.pm98
-rw-r--r--lib/Lintian/Check/Debian/Control/Field/Architecture/Multiline.pm63
-rw-r--r--lib/Lintian/Check/Debian/Control/Field/BuildProfiles.pm110
-rw-r--r--lib/Lintian/Check/Debian/Control/Field/BuiltUsing.pm66
-rw-r--r--lib/Lintian/Check/Debian/Control/Field/Description/Duplicate.pm114
-rw-r--r--lib/Lintian/Check/Debian/Control/Field/DoubledUp.pm83
-rw-r--r--lib/Lintian/Check/Debian/Control/Field/Empty.pm84
-rw-r--r--lib/Lintian/Check/Debian/Control/Field/Misplaced.pm67
-rw-r--r--lib/Lintian/Check/Debian/Control/Field/Redundant.pm68
-rw-r--r--lib/Lintian/Check/Debian/Control/Field/Relation.pm180
-rw-r--r--lib/Lintian/Check/Debian/Control/Field/RulesRequiresRoot.pm99
-rw-r--r--lib/Lintian/Check/Debian/Control/Field/Section.pm52
-rw-r--r--lib/Lintian/Check/Debian/Control/Field/Spacing.pm78
-rw-r--r--lib/Lintian/Check/Debian/Control/Link.pm57
-rw-r--r--lib/Lintian/Check/Debian/Control/Prerequisite/Circular.pm74
-rw-r--r--lib/Lintian/Check/Debian/Control/Prerequisite/Development.pm145
-rw-r--r--lib/Lintian/Check/Debian/Control/Prerequisite/Redundant.pm99
-rw-r--r--lib/Lintian/Check/Debian/Copyright.pm586
-rw-r--r--lib/Lintian/Check/Debian/Copyright/ApacheNotice.pm105
-rw-r--r--lib/Lintian/Check/Debian/Copyright/Dep5.pm968
-rw-r--r--lib/Lintian/Check/Debian/Copyright/Dep5/Components.pm109
-rw-r--r--lib/Lintian/Check/Debian/Debconf.pm794
-rw-r--r--lib/Lintian/Check/Debian/DesktopEntries.pm58
-rw-r--r--lib/Lintian/Check/Debian/Filenames.pm78
-rw-r--r--lib/Lintian/Check/Debian/Files.pm60
-rw-r--r--lib/Lintian/Check/Debian/LineSeparators.pm62
-rw-r--r--lib/Lintian/Check/Debian/LintianOverrides.pm64
-rw-r--r--lib/Lintian/Check/Debian/LintianOverrides/Comments.pm88
-rw-r--r--lib/Lintian/Check/Debian/LintianOverrides/Duplicate.pm75
-rw-r--r--lib/Lintian/Check/Debian/LintianOverrides/Malformed.pm52
-rw-r--r--lib/Lintian/Check/Debian/LintianOverrides/Mystery.pm65
-rw-r--r--lib/Lintian/Check/Debian/LintianOverrides/Restricted.pm80
-rw-r--r--lib/Lintian/Check/Debian/Maintscript.pm73
-rw-r--r--lib/Lintian/Check/Debian/ManualPages.pm67
-rw-r--r--lib/Lintian/Check/Debian/NotInstalled.pm74
-rw-r--r--lib/Lintian/Check/Debian/Patches.pm104
-rw-r--r--lib/Lintian/Check/Debian/Patches/Count.pm54
-rw-r--r--lib/Lintian/Check/Debian/Patches/Dep3.pm105
-rw-r--r--lib/Lintian/Check/Debian/Patches/Dpatch.pm150
-rw-r--r--lib/Lintian/Check/Debian/Patches/Quilt.pm290
-rw-r--r--lib/Lintian/Check/Debian/PoDebconf.pm391
-rw-r--r--lib/Lintian/Check/Debian/Readme.pm176
-rw-r--r--lib/Lintian/Check/Debian/Rules.pm671
-rw-r--r--lib/Lintian/Check/Debian/Rules/DhSequencer.pm65
-rw-r--r--lib/Lintian/Check/Debian/Shlibs.pm656
-rw-r--r--lib/Lintian/Check/Debian/Source/IncludeBinaries.pm77
-rw-r--r--lib/Lintian/Check/Debian/SourceDir.pm170
-rw-r--r--lib/Lintian/Check/Debian/Substvars.pm55
-rw-r--r--lib/Lintian/Check/Debian/Symbols.pm83
-rw-r--r--lib/Lintian/Check/Debian/TrailingWhitespace.pm105
-rw-r--r--lib/Lintian/Check/Debian/Upstream/Metadata.pm191
-rw-r--r--lib/Lintian/Check/Debian/Upstream/SigningKey.pm173
-rw-r--r--lib/Lintian/Check/Debian/Variables.pm60
-rw-r--r--lib/Lintian/Check/Debian/VersionSubstvars.pm206
-rw-r--r--lib/Lintian/Check/Debian/Watch.pm379
-rw-r--r--lib/Lintian/Check/Debian/Watch/Standard.pm98
57 files changed, 10224 insertions, 0 deletions
diff --git a/lib/Lintian/Check/Debian/Changelog.pm b/lib/Lintian/Check/Debian/Changelog.pm
new file mode 100644
index 0000000..faa7890
--- /dev/null
+++ b/lib/Lintian/Check/Debian/Changelog.pm
@@ -0,0 +1,970 @@
+# debian/changelog -- lintian check script -*- perl -*-
+
+# Copyright (C) 1998 Christian Schwarz
+# Copyright (C) 2019-2020 Chris Lamb <lamby@debian.org>
+# Copyright (C) 2021 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 Lintian::Check::Debian::Changelog;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Const::Fast;
+use Data::Validate::Domain;
+use Date::Format qw(time2str);
+use Email::Address::XS;
+use List::Util qw(first);
+use List::SomeUtils qw(any all uniq);
+use Path::Tiny;
+use Syntax::Keyword::Try;
+use Unicode::UTF8 qw(valid_utf8 decode_utf8 encode_utf8);
+
+use Lintian::Changelog;
+use Lintian::Changelog::Version;
+use Lintian::IPC::Run3 qw(safe_qx);
+use Lintian::Relation::Version qw(versions_gt);
+use Lintian::Spelling qw(check_spelling);
+
+const my $EMPTY => q{};
+const my $DOUBLE_QUOTE => q{"};
+const my $GREATER_THAN => q{>};
+const my $APPROXIMATELY_EQUAL => q{~};
+
+const my $NOT_EQUALS => q{!=};
+const my $ARROW => q{->};
+
+const my $MAXIMUM_WIDTH => 82;
+const my $FIRST_ARCHIVED_BUG_NUMBER => 50_004;
+const my $OUT_OF_REACH_BUG_NUMBER => 1_500_000;
+
+use Moo;
+use namespace::clean;
+
+with 'Lintian::Check';
+
+sub spelling_tag_emitter {
+ my ($self, $tag_name, $item, @orig_args) = @_;
+
+ my $pointer = $item->pointer($.);
+
+ return sub {
+ return $self->pointed_hint($tag_name, $pointer, @orig_args, @_);
+ };
+}
+
+sub source {
+ my ($self) = @_;
+
+ my $pkg = $self->processable->name;
+ my $processable = $self->processable;
+ my $group = $self->group;
+
+ my $changelog = $processable->changelog;
+ return
+ unless defined $changelog;
+
+ my @entries = @{$changelog->entries};
+ return
+ unless @entries;
+
+ my $latest_entry = $entries[0];
+
+ my $changelog_item = $self->processable->changelog_item;
+ my $latest_pointer = $changelog_item->pointer($latest_entry->position);
+
+ my $changes = $group->changes;
+ if ($changes) {
+ my $contents = path($changes->path)->slurp;
+ # make sure dot matches newlines, as well
+ if ($contents =~ qr/BEGIN PGP SIGNATURE.*END PGP SIGNATURE/ms) {
+
+ $self->pointed_hint('unreleased-changelog-distribution',
+ $latest_pointer)
+ if $latest_entry->Distribution eq 'UNRELEASED';
+ }
+ }
+
+ my $versionstring = $processable->fields->value('Version');
+ my $latest_version = Lintian::Changelog::Version->new;
+
+ try {
+ $latest_version->assign($versionstring, $processable->native);
+
+ } catch {
+ my $indicator= ($processable->native ? $EMPTY : 'non-') . 'native';
+ $self->pointed_hint('malformed-debian-changelog-version',
+ $latest_pointer,$versionstring, "(for $indicator)");
+ undef $latest_version;
+
+ # perlcritic 1.140-1 requires a semicolon on the next line
+ };
+
+ if (defined $latest_version) {
+
+ $self->pointed_hint(
+ 'hyphen-in-upstream-part-of-debian-changelog-version',
+ $latest_pointer,$latest_version->upstream)
+ if !$processable->native && $latest_version->upstream =~ qr/-/;
+
+ # unstable, testing, and stable shouldn't be used in Debian
+ # version numbers. unstable should get a normal version
+ # increment and testing and stable should get suite-specific
+ # versions.
+ #
+ # NMUs get a free pass because they need to work with the
+ # version number that was already there.
+ unless (length $latest_version->source_nmu) {
+ my $revision = $latest_version->maintainer_revision;
+ my $distribution = $latest_entry->Distribution;
+
+ $self->pointed_hint('version-refers-to-distribution',
+ $latest_pointer,$latest_version->literal)
+ if ($revision =~ /testing|(?:un)?stable/i)
+ || (
+ ($distribution eq 'unstable'|| $distribution eq 'experimental')
+ && $revision
+ =~ /woody|sarge|etch|lenny|squeeze|stretch|buster/);
+ }
+
+ my $examine = $latest_version->maintainer_revision;
+ $examine = $latest_version->upstream
+ unless $processable->native;
+
+ my $candidate_pattern = qr/rc|alpha|beta|pre(?:view|release)?/;
+ my $increment_pattern = qr/[^a-z].*|\Z/;
+
+ my ($candidate_string, $increment_string)
+ = ($examine =~ m/[^~a-z]($candidate_pattern)($increment_pattern)/sm);
+ if (length $candidate_string && !length $latest_version->source_nmu) {
+
+ $increment_string //= $EMPTY;
+
+ # remove rc-part and any preceding symbol
+ my $expected = $examine;
+ $expected =~ s/[\.\+\-\:]?\Q$candidate_string\E.*//;
+
+ my $suggestion = "$expected~$candidate_string$increment_string";
+
+ $self->pointed_hint(
+ 'rc-version-greater-than-expected-version',
+ $latest_pointer,
+ $examine,
+ $GREATER_THAN,
+ $expected,
+ "(consider using $suggestion)",
+ )
+ if $latest_version->maintainer_revision eq '1'
+ || $latest_version->maintainer_revision=~ /^0(?:\.1|ubuntu1)?$/
+ || $processable->native;
+ }
+ }
+
+ if (@entries > 1) {
+
+ my $previous_entry = $entries[1];
+ my $latest_timestamp = $latest_entry->Timestamp;
+ my $previous_timestamp = $previous_entry->Timestamp;
+
+ my $previous_version = Lintian::Changelog::Version->new;
+ try {
+ $previous_version->assign($previous_entry->Version,
+ $processable->native);
+ } catch {
+ my $indicator= ($processable->native ? $EMPTY : 'non-') . 'native';
+ $self->pointed_hint(
+ 'odd-historical-debian-changelog-version',
+ $changelog_item->pointer($previous_entry->position),
+ $previous_entry->Version,
+ "(for $indicator)"
+ );
+ undef $previous_version;
+ }
+
+ if ($latest_timestamp && $previous_timestamp) {
+
+ $self->pointed_hint(
+ 'latest-debian-changelog-entry-without-new-date',
+ $latest_pointer)
+ if $latest_timestamp <= $previous_timestamp
+ && lc($latest_entry->Distribution) ne 'unreleased';
+ }
+
+ if (defined $latest_version) {
+
+ # skip first
+ for my $entry (@entries[1..$#entries]) {
+
+ # cannot use parser; nativeness may differ
+ my ($no_epoch) = ($entry->Version =~ qr/^(?:[^:]+:)?([^:]+)$/);
+
+ next
+ unless defined $no_epoch;
+
+ # disallowed even if epochs differ; see tag description
+ if ( $latest_version->no_epoch eq $no_epoch
+ && $latest_entry->Source eq $entry->Source) {
+
+ $self->pointed_hint(
+'latest-debian-changelog-entry-reuses-existing-version',
+ $latest_pointer,
+ $latest_version->literal,
+ $APPROXIMATELY_EQUAL,
+ $entry->Version,
+ '(last used: '. $entry->Date . ')'
+ );
+
+ last;
+ }
+ }
+ }
+
+ if (defined $latest_version && defined $previous_version) {
+
+ # a reused version literal is caught by the broader previous check
+
+ # start with a reasonable default
+ my $expected_previous = $previous_version->literal;
+
+ $expected_previous = $latest_version->without_backport
+ if $latest_version->backport_release
+ && $latest_version->backport_revision
+ && $latest_version->debian_without_backport ne '0';
+
+ # find an appropriate prior version for a source NMU
+ if (length $latest_version->source_nmu) {
+
+ # can only do first nmu for now
+ $expected_previous = $latest_version->without_source_nmu
+ if $latest_version->source_nmu eq '1'
+ &&$latest_version->maintainer_revision =~ qr/\d+/
+ && $latest_version->maintainer_revision ne '0';
+ }
+
+ $self->pointed_hint(
+ 'changelog-file-missing-explicit-entry',$latest_pointer,
+ $previous_version->literal, $ARROW,
+ "$expected_previous (missing)", $ARROW,
+ $latest_version->literal
+ )
+ unless $previous_version->literal eq $expected_previous
+ || $latest_entry->Distribution eq 'bullseye'
+ || $previous_entry->Distribution eq 'bullseye'
+ || $latest_entry->Distribution =~ /-security$/i;
+
+ if ( $latest_version->epoch eq $previous_version->epoch
+ && $latest_version->upstream eq$previous_version->upstream
+ && $latest_entry->Source eq $previous_entry->Source
+ && !$processable->native) {
+
+ $self->pointed_hint(
+ 'possible-new-upstream-release-without-new-version',
+ $latest_pointer)
+ if $latest_entry->Changes
+ =~ /^\s*\*\s+new\s+upstream\s+(?:\S+\s+)?release\b/im;
+
+ my $non_consecutive = 0;
+
+ $non_consecutive = 1
+ if !length $latest_version->source_nmu
+ && $latest_version->maintainer_revision =~ /^\d+$/
+ && $previous_version->maintainer_revision =~ /^\d+$/
+ && $latest_version->maintainer_revision
+ != $previous_version->maintainer_revision + 1;
+
+ $non_consecutive = 1
+ if $latest_version->maintainer_revision eq
+ $previous_version->maintainer_revision
+ && $latest_version->source_nmu =~ /^\d+$/
+ && $previous_version->source_nmu =~ /^\d+$/
+ && $latest_version->source_nmu
+ != $previous_version->source_nmu + 1;
+
+ $non_consecutive = 1
+ if $latest_version->source_nmu =~ /^\d+$/
+ && !length $previous_version->source_nmu
+ && $latest_version->source_nmu != 1;
+
+ $self->pointed_hint(
+ 'non-consecutive-debian-revision',
+ $latest_pointer,$previous_version->literal,
+ $ARROW,$latest_version->literal
+ )if $non_consecutive;
+ }
+
+ if ($latest_version->epoch ne $previous_version->epoch) {
+ $self->pointed_hint(
+ 'epoch-change-without-comment',$latest_pointer,
+ $previous_version->literal, $ARROW,
+ $latest_version->literal
+ )unless $latest_entry->Changes =~ /\bepoch\b/im;
+
+ $self->pointed_hint(
+ 'epoch-changed-but-upstream-version-did-not-go-backwards',
+ $latest_pointer,$previous_version->literal,
+ $ARROW,$latest_version->literal
+ )
+ unless $processable->native
+ || versions_gt($previous_version->upstream,
+ $latest_version->upstream);
+ }
+ }
+ }
+
+ return;
+}
+
+# no copyright in udebs
+sub binary {
+ my ($self) = @_;
+
+ my $pkg = $self->processable->name;
+ my $processable = $self->processable;
+ my $group = $self->group;
+
+ my $is_symlink = 0;
+ my $native_pkg;
+ my $foreign_pkg;
+ my @doc_files;
+
+ # skip packages which have a /usr/share/doc/$pkg -> foo symlink
+ my $docfile = $processable->installed->lookup("usr/share/doc/$pkg");
+ return
+ if defined $docfile && $docfile->is_symlink;
+
+ # trailing slash in indicates a directory
+ my $docdir = $processable->installed->lookup("usr/share/doc/$pkg/");
+ @doc_files = grep { $_->is_file || $_->is_symlink } $docdir->children
+ if defined $docdir;
+ my @news_files
+ = grep { $_->basename =~ m{\A NEWS\.Debian (?:\.gz)? \Z}ixsm }@doc_files;
+
+ $self->pointed_hint('debian-news-file-not-compressed', $_->pointer)
+ for grep { $_->basename !~ m{\.gz$} } @news_files;
+
+ $self->pointed_hint('wrong-name-for-debian-news-file', $_->pointer)
+ for grep { $_->basename =~ m{\.gz$} && $_->basename ne 'NEWS.Debian.gz' }
+ @news_files;
+
+ my @changelog_files = grep {
+ $_->basename =~ m{\A changelog (?:\.html|\.Debian)? (?:\.gz)? \Z}xsm
+ } @doc_files;
+
+ # ubuntu permits symlinks; their profile suppresses the tag
+ $self->pointed_hint('debian-changelog-file-is-a-symlink', $_->pointer)
+ for grep { $_->is_symlink } @changelog_files;
+
+ $self->pointed_hint('changelog-file-not-compressed', $_->pointer)
+ for grep { $_->basename !~ m{ \.gz \Z}xsm } @changelog_files;
+
+ # Check if changelog files are compressed with gzip -9.
+ # It's a bit of an open question here what we should do
+ # with a file named ChangeLog. If there's also a
+ # changelog file, it might be a duplicate, or the packager
+ # may have installed NEWS as changelog intentionally.
+ for my $item (@changelog_files) {
+
+ next
+ unless $item->basename =~ m{ \.gz \Z}xsm;
+
+ my $resolved = $item->resolve_path;
+ next
+ unless defined $resolved;
+
+ $self->pointed_hint('changelog-not-compressed-with-max-compression',
+ $item->pointer)
+ unless $resolved->file_type =~ /max compression/;
+ }
+
+ my @html_changelogs
+ = grep { $_->basename =~ /^changelog\.html(?:\.gz)?$/ } @changelog_files;
+ my @text_changelogs
+ = grep { $_->basename =~ /^changelog(?:\.gz)?$/ } @changelog_files;
+
+ if (!@text_changelogs) {
+
+ $self->pointed_hint('html-changelog-without-text-version', $_->pointer)
+ for @html_changelogs;
+ }
+
+ my $packagepath = 'usr/share/doc/' . $self->processable->name;
+ my $news_item
+ = $self->processable->installed->resolve_path(
+ "$packagepath/NEWS.Debian.gz");
+
+ my $news;
+ if (defined $news_item && $news_item->is_file) {
+
+ my $bytes = safe_qx('gunzip', '-c', $news_item->unpacked_path);
+
+ # another check complains about invalid encoding
+ if (valid_utf8($bytes)) {
+
+ my $contents = decode_utf8($bytes);
+ my $newslog = Lintian::Changelog->new;
+ $newslog->parse($contents);
+
+ for my $error (@{$newslog->errors}) {
+
+ my $position = $error->[0];
+ my $condition = $error->[1];
+
+ my $pointer = $news_item->pointer($position);
+
+ $self->pointed_hint('syntax-error-in-debian-news-file',
+ $pointer, $DOUBLE_QUOTE . $condition . $DOUBLE_QUOTE);
+ }
+
+ # Some checks on the most recent entry.
+ if ($newslog->entries && defined @{$newslog->entries}[0]) {
+
+ $news = @{$newslog->entries}[0];
+
+ my $pointer = $news_item->pointer($news->position);
+
+ $self->pointed_hint(
+ 'debian-news-entry-has-strange-distribution',
+ $pointer,$news->Distribution)
+ if length $news->Distribution
+ && $news->Distribution eq 'UNRELEASED';
+
+ check_spelling(
+ $self->data,
+ $news->Changes,
+ $group->spelling_exceptions,
+ $self->spelling_tag_emitter(
+ 'spelling-error-in-news-debian', $news_item
+ )
+ );
+
+ $self->pointed_hint('debian-news-entry-uses-asterisk',$pointer)
+ if $news->Changes =~ /^ \s* [*] \s /x;
+ }
+ }
+ }
+
+ # is this a native Debian package?
+ # If the version is missing, we assume it to be non-native
+ # as it is the most likely case.
+ my $source = $processable->fields->value('Source');
+ my $source_version;
+ if ($processable->fields->declares('Source') && $source =~ m/\((.*)\)/) {
+ $source_version = $1;
+ } else {
+ $source_version = $processable->fields->value('Version');
+ }
+ if (defined $source_version) {
+ $native_pkg = ($source_version !~ m/-/);
+ } else {
+ # We do not know, but assume it to non-native as it is
+ # the most likely case.
+ $native_pkg = 0;
+ }
+ $source_version = $processable->fields->value('Version') || '0-1';
+ $foreign_pkg = (!$native_pkg && $source_version !~ m/-0\./);
+ # A version of 1.2.3-0.1 could be either, so in that
+ # case, both vars are false
+
+ if ($native_pkg) {
+ # native Debian package
+ if (any { m/^changelog(?:\.gz)?$/} map { $_->basename } @doc_files) {
+ # everything is fine
+ } elsif (my $chg
+ = first {$_->basename =~ m/^changelog[.]debian(?:\.gz)$/i;}
+ @doc_files) {
+ $self->pointed_hint('wrong-name-for-changelog-of-native-package',
+ $chg->pointer);
+
+ } else {
+ $self->hint(
+ 'no-changelog',
+ "usr/share/doc/$pkg/changelog.gz",
+ '(native package)'
+ );
+ }
+ } else {
+ # non-native (foreign :) Debian package
+
+ # 1. check for upstream changelog
+ my $found_upstream_text_changelog = 0;
+ if (
+ any { m/^changelog(\.html)?(?:\.gz)?$/ }
+ map { $_->basename } @doc_files
+ ) {
+ $found_upstream_text_changelog = 1 unless $1;
+ # everything is fine
+ } else {
+ # search for changelogs with wrong file name
+ for my $item (@doc_files) {
+
+ if ( $item->basename =~ m/^change/i
+ && $item->basename !~ m/debian/i) {
+
+ $self->pointed_hint('wrong-name-for-upstream-changelog',
+ $item->pointer);
+ last;
+ }
+ }
+ }
+
+ # 2. check for Debian changelog
+ if (
+ any { m/^changelog\.Debian(?:\.gz)?$/ }
+ map { $_->basename } @doc_files
+ ) {
+ # everything is fine
+ } elsif (my $chg
+ = first {$_->basename =~ m/^changelog\.debian(?:\.gz)?$/i;}
+ @doc_files) {
+ $self->pointed_hint('wrong-name-for-debian-changelog-file',
+ $chg->pointer);
+
+ } else {
+ if ($foreign_pkg && $found_upstream_text_changelog) {
+ $self->hint('debian-changelog-file-missing-or-wrong-name');
+
+ } elsif ($foreign_pkg) {
+ $self->hint(
+ 'no-changelog',
+ "usr/share/doc/$pkg/changelog.Debian.gz",
+ '(non-native package)'
+ );
+ }
+ # TODO: if uncertain whether foreign or native, either
+ # changelog.gz or changelog.debian.gz should exists
+ # though... but no tests catches this (extremely rare)
+ # border case... Keep in mind this is only happening if we
+ # have a -0.x version number... So not my priority to fix
+ # --Jeroen
+ }
+ }
+
+ my $changelog_item = $self->processable->changelog_item;
+ return
+ unless defined $changelog_item;
+
+ # another check complains about invalid encoding
+ my $changelog = $processable->changelog;
+
+ for my $error (@{$changelog->errors}) {
+
+ my $position = $error->[0];
+ my $condition = $error->[1];
+
+ my $pointer = $changelog_item->pointer($position);
+
+ $self->pointed_hint('syntax-error-in-debian-changelog',
+ $pointer, $DOUBLE_QUOTE . $condition . $DOUBLE_QUOTE);
+ }
+
+ # Check for some things in the raw changelog file and compute the
+ # "offset" to the first line of the first entry. We use this to
+ # report the line number of "too-long" lines. (#657402)
+ my $real_start = $self->check_dch($changelog_item);
+
+ my @entries = @{$changelog->entries};
+
+ # all versions from the changelog
+ my %allversions
+ = map { $_ => 1 } grep { defined } map { $_->Version } @entries;
+
+ # checks applying to all entries
+ for my $entry (@entries) {
+
+ my $position = $entry->position;
+ my $version = $entry->Version;
+
+ my $pointer = $changelog_item->pointer($position);
+
+ if (length $entry->Maintainer) {
+ my ($parsed) = Email::Address::XS->parse($entry->Maintainer);
+
+ unless ($parsed->is_valid) {
+
+ $self->pointed_hint(
+ 'bogus-mail-host-in-debian-changelog',
+ $pointer,$entry->Maintainer,"(for version $version)",
+ );
+ next;
+ }
+
+ unless (all { length }
+ ($parsed->address, $parsed->user, $parsed->host)) {
+ $self->pointed_hint(
+ 'bogus-mail-host-in-debian-changelog',
+ $pointer,$parsed->format,"(for version $version)",
+ );
+ next;
+ }
+
+ $self->pointed_hint(
+ 'bogus-mail-host-in-debian-changelog',
+ $pointer, $parsed->address,"(for version $version)",
+ )
+ unless is_domain($parsed->host,
+ {domain_disable_tld_validation => 1});
+ }
+ }
+
+ my $INVALID_DATES
+ = $self->data->load('changelog-file/invalid-dates',qr/\s*=\>\s*/);
+
+ if (@entries) {
+
+ # checks related to the latest entry
+ my $latest_entry = $entries[0];
+
+ my $latest_pointer = $changelog_item->pointer($latest_entry->position);
+
+ my $latest_timestamp = $latest_entry->Timestamp;
+
+ if ($latest_timestamp) {
+
+ my $warned = 0;
+ my $longdate = $latest_entry->Date;
+
+ for my $re ($INVALID_DATES->all()) {
+ if ($longdate =~ m/($re)/i) {
+
+ my $match = $1;
+ my $repl = $INVALID_DATES->value($re);
+
+ $self->pointed_hint('invalid-date-in-debian-changelog',
+ $latest_pointer,"($match", $ARROW, "$repl)");
+
+ $warned = 1;
+ }
+ }
+
+ my ($weekday_declared, $numberportion)
+ = split(m/,\s*/, $longdate, 2);
+ $numberportion //= $EMPTY;
+ my ($tz, $weekday_actual);
+
+ if ($numberportion =~ m/[ ]+ ([^ ]+)\Z/xsm) {
+ $tz = $1;
+ $weekday_actual = time2str('%a', $latest_timestamp, $tz);
+ }
+
+ if (not $warned and $tz and $weekday_declared ne $weekday_actual) {
+ my $real_weekday = time2str('%A', $latest_timestamp, $tz);
+ my $short_date = time2str('%Y-%m-%d', $latest_timestamp, $tz);
+ $self->pointed_hint('debian-changelog-has-wrong-day-of-week',
+ $latest_pointer,"$short_date was a $real_weekday");
+ }
+ }
+
+ # there is more than one changelog entry
+ if (@entries > 1) {
+
+ my $previous_entry = $entries[1];
+
+ my $previous_timestamp = $previous_entry->Timestamp;
+
+ $self->pointed_hint('latest-changelog-entry-without-new-date',
+ $latest_pointer)
+ if defined $latest_timestamp
+ && defined $previous_timestamp
+ && $latest_timestamp <= $previous_timestamp
+ && $latest_entry->Distribution ne 'UNRELEASED';
+
+ my $latest_dist = lc $latest_entry->Distribution;
+ my $previous_dist = lc $previous_entry->Distribution;
+
+ $self->pointed_hint('experimental-to-unstable-without-comment',
+ $latest_pointer)
+ if $latest_dist eq 'unstable'
+ && $previous_dist eq 'experimental'
+ && $latest_entry->Changes
+ !~ m{ \b to \s+ ['"\N{LEFT SINGLE QUOTATION MARK}\N{LEFT DOUBLE QUOTATION MARK}]? (?:unstable|sid) ['"\N{RIGHT SINGLE QUOTATION MARK}\N{RIGHT DOUBLE QUOTATION MARK}]? \b }imx;
+
+ my $changes = $group->changes;
+ if ($changes) {
+ my $changes_dist= lc $changes->fields->value('Distribution');
+
+ my %codename;
+ $codename{'unstable'} = 'sid';
+ my @normalized
+ = uniq map { $codename{$_} // $_ }
+ ($latest_dist, $changes_dist);
+
+ $self->pointed_hint(
+ 'changelog-distribution-does-not-match-changes-file',
+ $latest_pointer,$latest_dist,
+ $NOT_EQUALS, $changes_dist
+ )unless @normalized == 1;
+ }
+
+ }
+
+ # Some checks should only be done against the most recent
+ # changelog entry.
+ my $changes = $latest_entry->Changes || $EMPTY;
+
+ if (@entries == 1) {
+
+ if ($latest_entry->Version && $latest_entry->Version =~ /-1$/) {
+ $self->pointed_hint('initial-upload-closes-no-bugs',
+ $latest_pointer)
+ unless @{ $latest_entry->Closes };
+
+ $self->pointed_hint(
+ 'new-package-uses-date-based-version-number',
+ $latest_pointer,
+ $latest_entry->Version,
+ '(better: 0~' . $latest_entry->Version .')'
+ )if $latest_entry->Version =~ m/^\d{8}/;
+ }
+
+ $self->pointed_hint('changelog-is-dh_make-template',
+ $latest_pointer)
+ if $changes
+ =~ /(?:#?\s*)(?:\d|n)+ is the bug number of your ITP/i;
+ }
+
+ while ($changes =~ /(closes[\s;]*(?:bug)?\#?\s?\d{6,})[^\w]/ig) {
+
+ my $closes = $1;
+
+ $self->pointed_hint('possible-missing-colon-in-closes',
+ $latest_pointer, $closes)
+ if length $closes;
+ }
+
+ if ($changes =~ m/(TEMP-\d{7}-[0-9a-fA-F]{6})/) {
+
+ my $temporary_cve = $1;
+
+ $self->pointed_hint(
+ 'changelog-references-temp-security-identifier',
+ $latest_pointer, $temporary_cve);
+ }
+
+ # check for bad intended distribution
+ if (
+ $changes =~ m{uploads? \s+ to \s+
+ (?'intended'testing|unstable|experimental|sid)}xi
+ ){
+ my $intended = lc($+{intended});
+
+ $intended = 'unstable'
+ if $intended eq 'sid';
+
+ my $uploaded = $latest_entry->Distribution;
+
+ $self->pointed_hint('bad-intended-distribution', $latest_pointer,
+ "intended for $intended but uploaded to $uploaded")
+ if $uploaded ne $intended
+ && $uploaded ne 'UNRELEASED';
+ }
+
+ if ($changes =~ m{ (Close: \s+ [#] \d+) }xi) {
+
+ my $statement = $1;
+
+ $self->pointed_hint('misspelled-closes-bug', $latest_pointer,
+ $statement);
+ }
+
+ my $changesempty = $changes;
+ $changesempty =~ s/\W//gms;
+
+ $self->pointed_hint('changelog-empty-entry', $latest_pointer)
+ if !length $changesempty
+ && $latest_entry->Distribution ne 'UNRELEASED';
+
+ # before bug 50004 bts removed bug instead of archiving
+ for my $bug (@{$latest_entry->Closes}) {
+
+ $self->pointed_hint('improbable-bug-number-in-closes',
+ $latest_pointer, $bug)
+ if $bug < $FIRST_ARCHIVED_BUG_NUMBER
+ || $bug >= $OUT_OF_REACH_BUG_NUMBER;
+ }
+
+ # Compare against NEWS.Debian if available.
+ for my $field (qw/Distribution Urgency/) {
+
+ $self->pointed_hint(
+ 'changelog-news-debian-mismatch',
+ $news_item->pointer($news->position),
+ $field,
+ $latest_entry->$field,
+ $NOT_EQUALS,
+ $news->$field
+ )
+ if defined $news
+ && length $news->Version
+ && $news->Version eq $latest_entry->Version
+ && $news->$field ne $latest_entry->$field;
+ }
+
+ $self->pointed_hint(
+ 'debian-news-entry-has-unknown-version',
+ $news_item->pointer($news->position),
+ $news->Version
+ )
+ if defined $news
+ && length $news->Version
+ && !exists $allversions{$news->Version};
+
+ # Parse::DebianChangelog adds an additional space to the
+ # beginning of each line, so we have to adjust for that in the
+ # length check.
+ my @lines = split(/\n/, $changes);
+
+ # real start
+ my $position = $real_start;
+ for my $line (@lines) {
+
+ my $pointer = $changelog_item->pointer($position);
+
+ if ($line =~ /^ [*]\s(.{1,5})$/) {
+
+ my $excerpt = $1;
+
+ $self->pointed_hint('debian-changelog-line-too-short',
+ $pointer, $excerpt)
+ unless $1 =~ /:$/;
+ }
+
+ $self->pointed_hint('debian-changelog-line-too-long', $pointer)
+ if length $line >= $MAXIMUM_WIDTH
+ && $line !~ /^ [\s.o*+-]* (?: [Ss]ee:?\s+ )? \S+ $/msx;
+
+ } continue {
+ ++$position;
+ }
+
+ # Strip out all lines that contain the word spelling to avoid false
+ # positives on changelog entries for spelling fixes.
+ $changes =~ s/^.*(?:spelling|typo).*\n//gm;
+
+ check_spelling(
+ $self->data,
+ $changes,
+ $group->spelling_exceptions,
+ $self->spelling_tag_emitter(
+ 'spelling-error-in-changelog', $changelog_item
+ )
+ );
+ }
+
+ return;
+}
+
+# read the changelog itself and check for some issues we cannot find
+# with Parse::DebianChangelog. Also return the "real" line number for
+# the first line of text in the first entry.
+#
+sub check_dch {
+ my ($self) = @_;
+
+ my $unresolved = $self->processable->changelog_item;
+
+ # stop for dangling symbolic link
+ my $item = $unresolved->resolve_path;
+ return 0
+ unless defined $item;
+
+ # return empty changelog
+ return 0
+ unless $item->is_file && $item->is_open_ok;
+
+ # emacs only looks at the last "local variables" in a file, and only at
+ # one within 3000 chars of EOF and on the last page (^L), but that's a bit
+ # pesky to replicate. Demanding a match of $prefix and $suffix ought to
+ # be enough to avoid false positives.
+
+ my $contents;
+ if ($item->basename =~ m{ [.]gz $}x) {
+
+ my $bytes = safe_qx('gunzip', '-c', $item->unpacked_path);
+
+ return 0
+ unless valid_utf8($bytes);
+
+ $contents = decode_utf8($bytes);
+
+ } else {
+
+ # empty unless valis UTF-8
+ $contents = $item->decoded_utf8;
+ }
+
+ my @lines = split(m{\n}, $contents);
+
+ my $prefix;
+ my $suffix;
+ my $real_start = 0;
+
+ my $saw_tab_lead = 0;
+
+ my $position = 1;
+ for my $line (@lines) {
+
+ ++$real_start
+ unless $saw_tab_lead;
+
+ $saw_tab_lead = 1
+ if $line =~ /^\s+\S/;
+
+ my $pointer = $item->pointer($position);
+
+ if (
+ $line
+ =~ m{ closes: \s* (( (?:bug)? [#]? \s? \d*) [[:alpha:]] \w*) }ix
+ || $line =~ m{ closes: \s* (?:bug)? [#]? \s? \d+
+ (?: , \s* (?:bug)? [#]? \s? \d+ )*
+ (?: , \s* (( (?:bug)? [#]? \s? \d* ) [[:alpha:]] \w*)) }ix
+ ) {
+
+ my $bug = $1;
+
+ $self->pointed_hint('wrong-bug-number-in-closes', $pointer, $bug)
+ if length $2;
+ }
+
+ if ($line =~ /^(.*)Local\ variables:(.*)$/i) {
+ $prefix = $1;
+ $suffix = $2;
+ }
+
+ # emacs allows whitespace between prefix and variable, hence \s*
+ $self->pointed_hint(
+ 'debian-changelog-file-contains-obsolete-user-emacs-settings',
+ $pointer)
+ if defined $prefix
+ && defined $suffix
+ && $line =~ /^\Q$prefix\E\s*add-log-mailing-address:.*\Q$suffix\E$/;
+
+ } continue {
+ ++$position;
+ }
+
+ return $real_start;
+}
+
+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/Lintian/Check/Debian/Control/Field/Adopted.pm b/lib/Lintian/Check/Debian/Control/Field/Adopted.pm
new file mode 100644
index 0000000..d9d9379
--- /dev/null
+++ b/lib/Lintian/Check/Debian/Control/Field/Adopted.pm
@@ -0,0 +1,98 @@
+# debian/control/field/adopted -- lintian check script -*- perl -*-
+#
+# Copyright (C) 2004 Marc Brockschmidt
+# Copyright (C) 2020 Chris Lamb <lamby@debian.org>
+# Copyright (C) 2020-2021 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 Lintian::Check::Debian::Control::Field::Adopted;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Moo;
+use namespace::clean;
+
+with 'Lintian::Check';
+
+sub source {
+ my ($self) = @_;
+
+ my $control = $self->processable->debian_control;
+ my $source_fields = $control->source_fields;
+
+ my $KNOWN_SOURCE_FIELDS= $self->data->load('common/source-fields');
+ my $KNOWN_BINARY_FIELDS= $self->data->load('fields/binary-fields');
+
+ for my $field ($source_fields->names) {
+
+ my ($marker, $bare) = split(qr{-}, $field, 2);
+
+ next
+ unless length $marker
+ && length $bare;
+
+ my $control_item= $self->processable->debian_control->item;
+ my $position = $source_fields->position($field);
+ my $pointer = $control_item->pointer($position);
+
+ # case-insensitive match
+ $self->pointed_hint(
+ 'adopted-extended-field',$pointer,
+ '(in section for source)', $field
+ )
+ if $marker =~ m{^ X }ix
+ && $KNOWN_SOURCE_FIELDS->resembles($bare);
+ }
+
+ for my $installable ($control->installables) {
+ my $installable_fields = $control->installable_fields($installable);
+
+ for my $field ($installable_fields->names) {
+
+ my ($marker, $bare) = split(qr{-}, $field, 2);
+
+ next
+ unless length $marker
+ && length $bare;
+
+ my $control_item= $self->processable->debian_control->item;
+ my $position = $installable_fields->position($field);
+ my $pointer = $control_item->pointer($position);
+
+ # case-insensitive match
+ $self->pointed_hint(
+ 'adopted-extended-field', $pointer,
+ "(in section for $installable)", $field
+ )
+ if $marker =~ m{^ X }ix
+ && $KNOWN_BINARY_FIELDS->resembles($bare);
+ }
+ }
+
+ return;
+}
+
+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/Lintian/Check/Debian/Control/Field/Architecture/Multiline.pm b/lib/Lintian/Check/Debian/Control/Field/Architecture/Multiline.pm
new file mode 100644
index 0000000..dbb5dc2
--- /dev/null
+++ b/lib/Lintian/Check/Debian/Control/Field/Architecture/Multiline.pm
@@ -0,0 +1,63 @@
+# debian/control/field/architecture/multiline -- lintian check script -*- perl -*-
+#
+# Copyright (C) 2004 Marc Brockschmidt
+# Copyright (C) 2020 Chris Lamb <lamby@debian.org>
+# Copyright (C) 2020-2021 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 Lintian::Check::Debian::Control::Field::Architecture::Multiline;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Moo;
+use namespace::clean;
+
+with 'Lintian::Check';
+
+sub source {
+ my ($self) = @_;
+
+ my $control = $self->processable->debian_control;
+
+ for my $installable ($control->installables) {
+
+ my $installable_fields = $control->installable_fields($installable);
+
+ my $field = 'Architecture';
+
+ my $control_item= $self->processable->debian_control->item;
+ my $position = $installable_fields->position($field);
+ my $pointer = $control_item->pointer($position);
+
+ $self->pointed_hint('multiline-architecture-field',
+ $pointer, $field,"(in section for $installable)")
+ if $installable_fields->value($field)=~ /\n./;
+ }
+
+ return;
+}
+
+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/Lintian/Check/Debian/Control/Field/BuildProfiles.pm b/lib/Lintian/Check/Debian/Control/Field/BuildProfiles.pm
new file mode 100644
index 0000000..50e9663
--- /dev/null
+++ b/lib/Lintian/Check/Debian/Control/Field/BuildProfiles.pm
@@ -0,0 +1,110 @@
+# debian/control/field/build-profiles -- lintian check script -*- perl -*-
+#
+# Copyright (C) 2004 Marc Brockschmidt
+# Copyright (C) 2020 Chris Lamb <lamby@debian.org>
+# Copyright (C) 2020-2021 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 Lintian::Check::Debian::Control::Field::BuildProfiles;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Lintian::Relation;
+
+use Moo;
+use namespace::clean;
+
+with 'Lintian::Check';
+
+sub source {
+ my ($self) = @_;
+
+ my $control = $self->processable->debian_control;
+
+ my $KNOWN_BUILD_PROFILES= $self->data->load('fields/build-profiles');
+
+ for my $installable ($control->installables) {
+ my $installable_fields = $control->installable_fields($installable);
+
+ my $field = 'Build-Profiles';
+
+ my $raw = $installable_fields->value($field);
+ next
+ unless $raw;
+
+ my $control_item= $self->processable->debian_control->item;
+ my $position = $installable_fields->position($field);
+ my $pointer = $control_item->pointer($position);
+
+ if (
+ $raw!~ m{^\s* # skip leading whitespace
+ < # first list start
+ !?[^\s<>]+ # (possibly negated) term
+ (?: # any additional terms
+ \s+ # start with a space
+ !?[^\s<>]+ # (possibly negated) term
+ )* # zero or more additional terms
+ > # first list end
+ (?: # any additional restriction lists
+ \s+ # start with a space
+ < # additional list start
+ !?[^\s<>]+ # (possibly negated) term
+ (?: # any additional terms
+ \s+ # start with a space
+ !?[^\s<>]+ # (possibly negated) term
+ )* # zero or more additional terms
+ > # additional list end
+ )* # zero or more additional lists
+ \s*$ # trailing spaces at the end
+ }x
+ ) {
+ $self->pointed_hint(
+ 'invalid-restriction-formula-in-build-profiles-field',
+ $pointer, $raw,"(in section for $installable)");
+
+ } else {
+ # parse the field and check the profile names
+ $raw =~ s/^\s*<(.*)>\s*$/$1/;
+
+ for my $restrlist (split />\s+</, $raw) {
+ for my $profile (split /\s+/, $restrlist) {
+
+ $profile =~ s/^!//;
+
+ $self->pointed_hint(
+ 'invalid-profile-name-in-build-profiles-field',
+ $pointer, $profile,"(in section for $installable)")
+ unless $KNOWN_BUILD_PROFILES->recognizes($profile)
+ || $profile =~ /^pkg\.[a-z0-9][a-z0-9+.-]+\../;
+ }
+ }
+ }
+ }
+
+ return;
+}
+
+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/Lintian/Check/Debian/Control/Field/BuiltUsing.pm b/lib/Lintian/Check/Debian/Control/Field/BuiltUsing.pm
new file mode 100644
index 0000000..560f89b
--- /dev/null
+++ b/lib/Lintian/Check/Debian/Control/Field/BuiltUsing.pm
@@ -0,0 +1,66 @@
+# debian/control/field/built-using -- lintian check script -*- perl -*-
+#
+# Copyright (C) 2004 Marc Brockschmidt
+# Copyright (C) 2020 Chris Lamb <lamby@debian.org>
+# Copyright (C) 2020-2021 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 Lintian::Check::Debian::Control::Field::BuiltUsing;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Moo;
+use namespace::clean;
+
+with 'Lintian::Check';
+
+sub source {
+ my ($self) = @_;
+
+ my $control = $self->processable->debian_control;
+
+ for my $installable ($control->installables) {
+ my $installable_fields= $control->installable_fields($installable);
+
+ my $field = 'Built-Using';
+
+ my $control_item= $self->processable->debian_control->item;
+ my $position = $installable_fields->position($field);
+ my $pointer = $control_item->pointer($position);
+
+ $self->pointed_hint(
+ 'built-using-field-on-arch-all-package',$pointer,
+ "(in section for $installable)", $field,
+ $installable_fields->value($field)
+ )
+ if $installable_fields->declares($field)
+ && $installable_fields->value('Architecture') eq 'all';
+ }
+
+ return;
+}
+
+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/Lintian/Check/Debian/Control/Field/Description/Duplicate.pm b/lib/Lintian/Check/Debian/Control/Field/Description/Duplicate.pm
new file mode 100644
index 0000000..294893b
--- /dev/null
+++ b/lib/Lintian/Check/Debian/Control/Field/Description/Duplicate.pm
@@ -0,0 +1,114 @@
+# debian/control/field/description/duplicate -- lintian check script -*- perl -*-
+#
+# Copyright (C) 2004 Marc Brockschmidt
+# Copyright (C) 2020 Chris Lamb <lamby@debian.org>
+# Copyright (C) 2020-2021 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 Lintian::Check::Debian::Control::Field::Description::Duplicate;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Const::Fast;
+
+use Moo;
+use namespace::clean;
+
+with 'Lintian::Check';
+
+const my $EMPTY => q{};
+
+sub source {
+ my ($self) = @_;
+
+ my $control = $self->processable->debian_control;
+
+ my %installables_by_synopsis;
+ my %installables_by_exended;
+
+ for my $installable ($control->installables) {
+
+ next
+ if $control->installable_package_type($installable) eq 'udeb';
+
+ my $installable_fields = $control->installable_fields($installable);
+
+ my $description = $installable_fields->untrimmed_value('Description');
+ next
+ unless length $description;
+
+ my ($synopsis, $extended) = split(/\n/, $description, 2);
+
+ $synopsis //= $EMPTY;
+ $extended //= $EMPTY;
+
+ # trim both ends
+ $synopsis =~ s/^\s+|\s+$//g;
+ $extended =~ s/^\s+|\s+$//g;
+
+ if (length $synopsis) {
+ $installables_by_synopsis{$synopsis} //= [];
+ push(@{$installables_by_synopsis{$synopsis}}, $installable);
+ }
+
+ if (length $extended) {
+ $installables_by_exended{$extended} //= [];
+ push(@{$installables_by_exended{$extended}}, $installable);
+ }
+ }
+
+ # check for duplicate short description
+ for my $synopsis (keys %installables_by_synopsis) {
+
+ # Assume that substvars are correctly handled
+ next
+ if $synopsis =~ m/\$\{.+\}/;
+
+ $self->pointed_hint(
+ 'duplicate-short-description',
+ $control->item->pointer,
+ (sort @{$installables_by_synopsis{$synopsis}})
+ )if scalar @{$installables_by_synopsis{$synopsis}} > 1;
+ }
+
+ # check for duplicate long description
+ for my $extended (keys %installables_by_exended) {
+
+ # Assume that substvars are correctly handled
+ next
+ if $extended =~ m/\$\{.+\}/;
+
+ $self->pointed_hint(
+ 'duplicate-long-description',
+ $control->item->pointer,
+ (sort @{$installables_by_exended{$extended}})
+ )if scalar @{$installables_by_exended{$extended}} > 1;
+ }
+
+ return;
+}
+
+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/Lintian/Check/Debian/Control/Field/DoubledUp.pm b/lib/Lintian/Check/Debian/Control/Field/DoubledUp.pm
new file mode 100644
index 0000000..1e1e69a
--- /dev/null
+++ b/lib/Lintian/Check/Debian/Control/Field/DoubledUp.pm
@@ -0,0 +1,83 @@
+# debian/control/field/doubled-up -- lintian check script -*- perl -*-
+#
+# Copyright (C) 2004 Marc Brockschmidt
+# Copyright (C) 2020 Chris Lamb <lamby@debian.org>
+# Copyright (C) 2020-2021 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 Lintian::Check::Debian::Control::Field::DoubledUp;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Moo;
+use namespace::clean;
+
+with 'Lintian::Check';
+
+sub source {
+ my ($self) = @_;
+
+ my $control = $self->processable->debian_control;
+ my $source_fields = $control->source_fields;
+
+ # something like "Maintainer: Maintainer: bad field"
+ my @doubled_up_source_fields
+ = grep { $source_fields->value($_) =~ m{^ \Q$_\E \s* : }ix }
+ $source_fields->names;
+
+ for my $field (@doubled_up_source_fields) {
+
+ my $control_item= $self->processable->debian_control->item;
+ my $position = $source_fields->position($field);
+ my $pointer = $control_item->pointer($position);
+
+ $self->pointed_hint('debian-control-repeats-field-name-in-value',
+ $pointer, '(in section for source)', $field);
+ }
+
+ for my $installable ($control->installables) {
+ my $installable_fields = $control->installable_fields($installable);
+
+ # something like "Maintainer: Maintainer: bad field"
+ my @doubled_up_installable_fields
+ = grep { $installable_fields->value($_) =~ m{^ \Q$_\E \s* : }ix }
+ $installable_fields->names;
+
+ for my $field (@doubled_up_installable_fields) {
+
+ my $control_item= $self->processable->debian_control->item;
+ my $position = $installable_fields->position($field);
+ my $pointer = $control_item->pointer($position);
+
+ $self->pointed_hint('debian-control-repeats-field-name-in-value',
+ $pointer,"(in section for $installable)", $field);
+ }
+ }
+
+ return;
+}
+
+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/Lintian/Check/Debian/Control/Field/Empty.pm b/lib/Lintian/Check/Debian/Control/Field/Empty.pm
new file mode 100644
index 0000000..15b48ca
--- /dev/null
+++ b/lib/Lintian/Check/Debian/Control/Field/Empty.pm
@@ -0,0 +1,84 @@
+# debian/control/field/empty -- lintian check script -*- perl -*-
+#
+# Copyright (C) 2004 Marc Brockschmidt
+# Copyright (C) 2020 Chris Lamb <lamby@debian.org>
+# Copyright (C) 2020-2021 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 Lintian::Check::Debian::Control::Field::Empty;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Moo;
+use namespace::clean;
+
+with 'Lintian::Check';
+
+sub source {
+ my ($self) = @_;
+
+ my $control = $self->processable->debian_control;
+ my $source_fields = $control->source_fields;
+
+ my @empty_source_fields
+ = grep { !length $source_fields->value($_) } $source_fields->names;
+
+ for my $field (@empty_source_fields) {
+
+ my $control_item= $self->processable->debian_control->item;
+ my $position = $source_fields->position($field);
+ my $pointer = $control_item->pointer($position);
+
+ $self->pointed_hint(
+ 'debian-control-has-empty-field', $pointer,
+ '(in source paragraph)', $field
+ );
+ }
+
+ for my $installable ($control->installables) {
+ my $installable_fields = $control->installable_fields($installable);
+
+ my @empty_installable_fields
+ = grep { !length $installable_fields->value($_) }
+ $installable_fields->names;
+
+ for my $field (@empty_installable_fields) {
+
+ my $control_item= $self->processable->debian_control->item;
+ my $position = $installable_fields->position($field);
+ my $pointer = $control_item->pointer($position);
+
+ $self->pointed_hint(
+ 'debian-control-has-empty-field',$pointer,
+ "(in section for $installable)", $field
+ );
+ }
+ }
+
+ return;
+}
+
+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/Lintian/Check/Debian/Control/Field/Misplaced.pm b/lib/Lintian/Check/Debian/Control/Field/Misplaced.pm
new file mode 100644
index 0000000..743be38
--- /dev/null
+++ b/lib/Lintian/Check/Debian/Control/Field/Misplaced.pm
@@ -0,0 +1,67 @@
+# debian/control/field/misplaced -- lintian check script -*- perl -*-
+#
+# Copyright (C) 2004 Marc Brockschmidt
+# Copyright (C) 2020 Chris Lamb <lamby@debian.org>
+# Copyright (C) 2020-2021 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 Lintian::Check::Debian::Control::Field::Misplaced;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Moo;
+use namespace::clean;
+
+with 'Lintian::Check';
+
+sub source {
+ my ($self) = @_;
+
+ my $control = $self->processable->debian_control;
+ my $source_fields = $control->source_fields;
+
+ my @build_fields
+ =qw{Build-Depends Build-Depends-Indep Build-Conflicts Build-Conflicts-Indep};
+
+ for my $installable ($control->installables) {
+ my $installable_fields = $control->installable_fields($installable);
+
+ for my $field (@build_fields) {
+
+ my $control_item= $self->processable->debian_control->item;
+ my $position = $installable_fields->position($field);
+ my $pointer = $control_item->pointer($position);
+
+ $self->pointed_hint('build-prerequisite-in-installable-section',
+ $pointer, $field,"(in section for $installable)")
+ if $installable_fields->declares($field);
+ }
+ }
+
+ return;
+}
+
+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/Lintian/Check/Debian/Control/Field/Redundant.pm b/lib/Lintian/Check/Debian/Control/Field/Redundant.pm
new file mode 100644
index 0000000..9f78dd4
--- /dev/null
+++ b/lib/Lintian/Check/Debian/Control/Field/Redundant.pm
@@ -0,0 +1,68 @@
+# debian/control/field/redundant -- lintian check script -*- perl -*-
+#
+# Copyright (C) 2004 Marc Brockschmidt
+# Copyright (C) 2020 Chris Lamb <lamby@debian.org>
+# Copyright (C) 2020-2021 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 Lintian::Check::Debian::Control::Field::Redundant;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Moo;
+use namespace::clean;
+
+with 'Lintian::Check';
+
+sub source {
+ my ($self) = @_;
+
+ my $control = $self->processable->debian_control;
+ my $source_fields = $control->source_fields;
+
+ for my $installable ($control->installables) {
+ my $installable_fields = $control->installable_fields($installable);
+
+ for my $field ($installable_fields->names) {
+
+ my $control_item= $self->processable->debian_control->item;
+ my $position = $installable_fields->position($field);
+ my $pointer = $control_item->pointer($position);
+
+ $self->pointed_hint(
+ 'installable-field-mirrors-source',$pointer,
+ "(in section for $installable)", $field
+ )
+ if $source_fields->declares($field)
+ && $installable_fields->value($field) eq
+ $source_fields->value($field);
+ }
+ }
+
+ return;
+}
+
+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/Lintian/Check/Debian/Control/Field/Relation.pm b/lib/Lintian/Check/Debian/Control/Field/Relation.pm
new file mode 100644
index 0000000..3047971
--- /dev/null
+++ b/lib/Lintian/Check/Debian/Control/Field/Relation.pm
@@ -0,0 +1,180 @@
+# debian/control/field/relation -- lintian check script -*- perl -*-
+#
+# Copyright (C) 2004 Marc Brockschmidt
+# Copyright (C) 2020 Chris Lamb <lamby@debian.org>
+# Copyright (C) 2020-2021 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 Lintian::Check::Debian::Control::Field::Relation;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Lintian::Relation;
+
+use Moo;
+use namespace::clean;
+
+with 'Lintian::Check';
+
+sub source {
+ my ($self) = @_;
+
+ my $control = $self->processable->debian_control;
+ my $source_fields = $control->source_fields;
+
+ # Check that fields which should be comma-separated or
+ # pipe-separated have separators. Places where this tends to
+ # cause problems are with wrapped lines such as:
+ #
+ # Depends: foo, bar
+ # baz
+ #
+ # or with substvars. If two substvars aren't separated by a
+ # comma, but at least one of them expands to an empty string,
+ # there will be a lurking bug. The result will be syntactically
+ # correct, but as soon as both expand into something non-empty,
+ # there will be a syntax error.
+ #
+ # The architecture list can contain things that look like packages
+ # separated by spaces, so we have to remove any architecture
+ # restrictions first. This unfortunately distorts our report a
+ # little, but hopefully not too much.
+ #
+ # Also check for < and > relations. dpkg-gencontrol warns about
+ # them and then transforms them in the output to <= and >=, but
+ # it's easy to miss the error message. Similarly, check for
+ # duplicates, which dpkg-source eliminates.
+
+ for my $field (
+ qw(Build-Depends Build-Depends-Indep
+ Build-Conflicts Build-Conflicts-Indep)
+ ) {
+ next
+ unless $source_fields->declares($field);
+
+ my $control_item= $self->processable->debian_control->item;
+ my $position = $source_fields->position($field);
+ my $pointer = $control_item->pointer($position);
+
+ my @values = $source_fields->trimmed_list($field, qr{ \s* , \s* }x);
+ my @obsolete = grep { m{ [(] [<>] \s* [^<>=]+ [)] }x } @values;
+
+ $self->pointed_hint(
+ 'obsolete-relation-form-in-source',
+ $pointer, '(in source paragraph)',
+ $field, $_
+ )for @obsolete;
+
+ my $raw = $source_fields->value($field);
+ my $relation = Lintian::Relation->new->load($raw);
+
+ for my $redundant_set ($relation->redundancies) {
+
+ $self->pointed_hint('redundant-control-relation', $pointer,
+ '(in source paragraph)',
+ $field,join(', ', sort @{$redundant_set}));
+ }
+
+ $self->check_separators($raw, $pointer, '(in source paragraph)');
+ }
+
+ for my $installable ($control->installables) {
+ my $installable_fields = $control->installable_fields($installable);
+
+ for my $field (
+ qw(Pre-Depends Depends Recommends Suggests Breaks
+ Conflicts Provides Replaces Enhances)
+ ) {
+ next
+ unless $installable_fields->declares($field);
+
+ my $control_item= $self->processable->debian_control->item;
+ my $position = $installable_fields->position($field);
+ my $pointer = $control_item->pointer($position);
+
+ my @values
+ = $installable_fields->trimmed_list($field, qr{ \s* , \s* }x);
+ my @obsolete = grep { m{ [(] [<>] \s* [^<>=]+ [)] }x } @values;
+
+ $self->pointed_hint(
+ 'obsolete-relation-form-in-source',
+ $pointer, "(in section for $installable)",
+ $field, $_
+ )for @obsolete;
+
+ my $relation
+ = $self->processable->binary_relation($installable, $field);
+
+ for my $redundant_set ($relation->redundancies) {
+
+ $self->pointed_hint(
+ 'redundant-control-relation', $pointer,
+ "(in section for $installable)", $field,
+ join(', ', sort @{$redundant_set})
+ );
+ }
+
+ my $raw = $installable_fields->value($field);
+ $self->check_separators($raw, $pointer,
+ "(in section for $installable)");
+ }
+ }
+
+ return;
+}
+
+sub check_separators {
+ my ($self, $string, $pointer, $explainer) = @_;
+
+ $string =~ s/\n(\s)/$1/g;
+ $string =~ s/\[[^\]]*\]//g;
+
+ if (
+ $string =~ m{(?:^|\s)
+ (
+ (?:\w[^\s,|\$\(]+|\$\{\S+:Depends\})\s*
+ (?:\([^\)]*\)\s*)?
+ )
+ \s+
+ (
+ (?:\w[^\s,|\$\(]+|\$\{\S+:Depends\})\s*
+ (?:\([^\)]*\)\s*)?
+ )}x
+ ) {
+ my ($prev, $next) = ($1, $2);
+
+ # trim right
+ $prev =~ s/\s+$//;
+ $next =~ s/\s+$//;
+
+ $self->pointed_hint('missing-separator-between-items',
+ $pointer,$explainer, "'$prev' and '$next'");
+ }
+
+ return;
+}
+
+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/Lintian/Check/Debian/Control/Field/RulesRequiresRoot.pm b/lib/Lintian/Check/Debian/Control/Field/RulesRequiresRoot.pm
new file mode 100644
index 0000000..b97a673
--- /dev/null
+++ b/lib/Lintian/Check/Debian/Control/Field/RulesRequiresRoot.pm
@@ -0,0 +1,99 @@
+# debian/control/field/rules-requires-root -- lintian check script -*- perl -*-
+#
+# Copyright (C) 2004 Marc Brockschmidt
+# Copyright (C) 2020 Chris Lamb <lamby@debian.org>
+# Copyright (C) 2020-2021 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 Lintian::Check::Debian::Control::Field::RulesRequiresRoot;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use List::SomeUtils qw(first_value);
+
+use Moo;
+use namespace::clean;
+
+with 'Lintian::Check';
+
+sub source {
+ my ($self) = @_;
+
+ my $control = $self->processable->debian_control;
+ my $source_fields = $control->source_fields;
+
+ my @r3_misspelled = grep { $_ ne 'Rules-Requires-Root' }
+ grep { m{^ Rules? - Requires? - Roots? $}xi } $source_fields->names;
+
+ for my $field (@r3_misspelled) {
+
+ my $control_item= $self->processable->debian_control->item;
+ my $position = $source_fields->position($field);
+ my $pointer = $control_item->pointer($position);
+
+ $self->pointed_hint('spelling-error-in-rules-requires-root',
+ $pointer, $field);
+ }
+
+ my $control_item= $self->processable->debian_control->item;
+ my $position = $source_fields->position('Rules-Requires-Root');
+ my $pointer = $control_item->pointer($position);
+
+ $self->pointed_hint('rules-do-not-require-root', $pointer)
+ if $source_fields->value('Rules-Requires-Root') eq 'no';
+
+ $self->pointed_hint('rules-require-root-explicitly', $pointer)
+ if $source_fields->declares('Rules-Requires-Root')
+ && $source_fields->value('Rules-Requires-Root') ne 'no';
+
+ $self->pointed_hint('silent-on-rules-requiring-root', $pointer)
+ unless $source_fields->declares('Rules-Requires-Root');
+
+ if ( !$source_fields->declares('Rules-Requires-Root')
+ || $source_fields->value('Rules-Requires-Root') eq 'no') {
+
+ for my $installable ($self->group->get_installables) {
+
+ my $user_owned_item
+ = first_value { $_->owner ne 'root' || $_->group ne 'root' }
+ @{$installable->installed->sorted_list};
+
+ next
+ unless defined $user_owned_item;
+
+ my $owner = $user_owned_item->owner;
+ my $group = $user_owned_item->group;
+
+ $self->pointed_hint('rules-silently-require-root',
+ $pointer, $installable->name,
+ "($owner:$group)", $user_owned_item->name);
+ }
+ }
+
+ return;
+}
+
+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/Lintian/Check/Debian/Control/Field/Section.pm b/lib/Lintian/Check/Debian/Control/Field/Section.pm
new file mode 100644
index 0000000..dd0ba52
--- /dev/null
+++ b/lib/Lintian/Check/Debian/Control/Field/Section.pm
@@ -0,0 +1,52 @@
+# debian/control/field/section -- lintian check script -*- perl -*-
+#
+# Copyright (C) 2004 Marc Brockschmidt
+# Copyright (C) 2020 Chris Lamb <lamby@debian.org>
+# Copyright (C) 2020-2021 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 Lintian::Check::Debian::Control::Field::Section;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Moo;
+use namespace::clean;
+
+with 'Lintian::Check';
+
+sub source {
+ my ($self) = @_;
+
+ my $control = $self->processable->debian_control;
+ my $source_fields = $control->source_fields;
+
+ $self->pointed_hint('no-source-section', $control->item->pointer)
+ unless $source_fields->declares('Section');
+
+ return;
+}
+
+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/Lintian/Check/Debian/Control/Field/Spacing.pm b/lib/Lintian/Check/Debian/Control/Field/Spacing.pm
new file mode 100644
index 0000000..070ebdf
--- /dev/null
+++ b/lib/Lintian/Check/Debian/Control/Field/Spacing.pm
@@ -0,0 +1,78 @@
+# debian/control/field/spacing -- lintian check script -*- perl -*-
+#
+# Copyright (C) 2004 Marc Brockschmidt
+# Copyright (C) 2020 Chris Lamb <lamby@debian.org>
+# Copyright (C) 2020-2021 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 Lintian::Check::Debian::Control::Field::Spacing;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Moo;
+use namespace::clean;
+
+with 'Lintian::Check';
+
+sub source {
+ my ($self) = @_;
+
+ my $item = $self->processable->debian_control->item;
+ return
+ unless defined $item;
+
+ my @lines = split(/\n/, $item->decoded_utf8);
+
+ my $position = 1;
+ while (defined(my $line = shift @lines)) {
+
+ # strip leading spaces
+ $line =~ s{\s*$}{};
+
+ next
+ if $line =~ m{^ [#]}x;
+
+ # line with field:
+ if ($line =~ m{^ (\S+) : }x) {
+
+ my $field = $1;
+
+ my $pointer = $item->pointer($position);
+
+ $self->pointed_hint('debian-control-has-unusual-field-spacing',
+ $pointer, $field)
+ unless $line =~ m{^ \S+ : [ ] \S }x
+ || $line =~ m{^ \S+ : $}x;
+ }
+
+ } continue {
+ ++$position;
+ }
+
+ return;
+}
+
+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/Lintian/Check/Debian/Control/Link.pm b/lib/Lintian/Check/Debian/Control/Link.pm
new file mode 100644
index 0000000..5f3f751
--- /dev/null
+++ b/lib/Lintian/Check/Debian/Control/Link.pm
@@ -0,0 +1,57 @@
+# debian/control/link -- lintian check script -*- perl -*-
+#
+# Copyright (C) 2004 Marc Brockschmidt
+# Copyright (C) 2020 Chris Lamb <lamby@debian.org>
+# Copyright (C) 2020-2021 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 Lintian::Check::Debian::Control::Link;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Moo;
+use namespace::clean;
+
+with 'Lintian::Check';
+
+sub source {
+ my ($self) = @_;
+
+ my $debian_dir = $self->processable->patched->resolve_path('debian/');
+ return
+ unless $debian_dir;
+
+ my $item = $debian_dir->child('control');
+ return
+ unless $item;
+
+ $self->pointed_hint('debian-control-file-is-a-symlink', $item->pointer)
+ if $item->is_symlink;
+
+ return;
+}
+
+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/Lintian/Check/Debian/Control/Prerequisite/Circular.pm b/lib/Lintian/Check/Debian/Control/Prerequisite/Circular.pm
new file mode 100644
index 0000000..7cd78e5
--- /dev/null
+++ b/lib/Lintian/Check/Debian/Control/Prerequisite/Circular.pm
@@ -0,0 +1,74 @@
+# debian/control/prerequisite/circular -- lintian check script -*- perl -*-
+#
+# Copyright (C) 2004 Marc Brockschmidt
+# Copyright (C) 2020 Chris Lamb <lamby@debian.org>
+# Copyright (C) 2020-2021 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 Lintian::Check::Debian::Control::Prerequisite::Circular;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Moo;
+use namespace::clean;
+
+with 'Lintian::Check';
+
+sub source {
+ my ($self) = @_;
+
+ my $control = $self->processable->debian_control;
+
+ my @prerequisite_fields = qw(Pre-Depends Depends Recommends Suggests);
+
+ for my $installable ($control->installables) {
+ my $installable_fields = $control->installable_fields($installable);
+
+ for my $field (@prerequisite_fields) {
+
+ next
+ unless $control->installable_fields($installable)
+ ->declares($field);
+
+ my $relation
+ = $self->processable->binary_relation($installable, $field);
+
+ my $control_item= $self->processable->debian_control->item;
+ my $position = $installable_fields->position($field);
+ my $pointer = $control_item->pointer($position);
+
+ $self->pointed_hint(
+ 'circular-installation-prerequisite',
+ $pointer, "(in section for $installable)",
+ $field,$relation->to_string
+ )if $relation->satisfies($installable);
+ }
+ }
+
+ return;
+}
+
+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/Lintian/Check/Debian/Control/Prerequisite/Development.pm b/lib/Lintian/Check/Debian/Control/Prerequisite/Development.pm
new file mode 100644
index 0000000..948076f
--- /dev/null
+++ b/lib/Lintian/Check/Debian/Control/Prerequisite/Development.pm
@@ -0,0 +1,145 @@
+# debian/control/prerequisite/development -- lintian check script -*- perl -*-
+#
+# Copyright (C) 2004 Marc Brockschmidt
+# Copyright (C) 2020 Chris Lamb <lamby@debian.org>
+# Copyright (C) 2020-2021 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 Lintian::Check::Debian::Control::Prerequisite::Development;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Const::Fast;
+use List::SomeUtils qw(any);
+
+use Moo;
+use namespace::clean;
+
+with 'Lintian::Check';
+
+const my $EMPTY => q{};
+
+sub source {
+ my ($self) = @_;
+
+ my $control = $self->processable->debian_control;
+
+ for my $installable ($control->installables) {
+ my $installable_fields = $control->installable_fields($installable);
+
+ next
+ unless $installable =~ /-dev$/;
+
+ my $field = 'Depends';
+
+ next
+ unless $installable_fields->declares($field);
+
+ my $control_item= $self->processable->debian_control->item;
+ my $position = $installable_fields->position($field);
+ my $pointer = $control_item->pointer($position);
+
+ my @depends
+ = $installable_fields->trimmed_list($field, qr{ \s* , \s* }x);
+
+ for my $other_name ($control->installables) {
+
+ next
+ if $other_name =~ /-(?:dev|docs?|common)$/;
+
+ next
+ unless $other_name =~ /^lib[\w.+-]+\d/;
+
+ my @relevant
+ = grep { m{ (?: ^ | [\s|] ) \Q$other_name\E (?: [\s|(] | \z ) }x }
+ @depends;
+
+ # If there are any alternatives here, something special is
+ # going on. Assume that the maintainer knows what they're
+ # doing. Otherwise, separate out just the versions.
+ next
+ if any { m{ [|] }x } @relevant;
+
+ my @unsorted;
+ for my $package (@relevant) {
+
+ $package =~ m{^ [\w.+-]+ \s* [(] ([^)]+) [)] }x;
+ push(@unsorted, ($1 // $EMPTY));
+ }
+
+ my @versions = sort @unsorted;
+
+ my $context;
+
+ # If there's only one mention of this package, the dependency
+ # should be tight. Otherwise, there should be both >>/>= and
+ # <</<= dependencies that mention the source, binary, or
+ # upstream version. If there are more than three mentions of
+ # the package, again something is weird going on, so we assume
+ # they know what they're doing.
+ if (@relevant == 1) {
+ unless ($versions[0]
+ =~ /^\s*=\s*\$\{(?:binary:Version|Source-Version)\}/) {
+ # Allow "pkg (= ${source:Version})" if (but only if)
+ # the target is an arch:all package. This happens
+ # with a lot of mono-packages.
+ #
+ # Note, we do not check if the -dev package is
+ # arch:all as well. The version-substvars check
+ # handles that for us.
+ next
+ if $control->installable_fields($other_name)
+ ->value('Architecture') eq 'all'
+ && $versions[0]
+ =~ m{^ \s* = \s* \$[{]source:Version[}] }x;
+
+ $context = $relevant[0];
+ }
+
+ } elsif (@relevant == 2) {
+ unless (
+ $versions[0] =~ m{^ \s* <[=<] \s* \$[{]
+ (?: (?:binary|source):(?:Upstream-)?Version
+ | Source-Version) [}] }xsm
+ && $versions[1] =~ m{^ \s* >[=>] \s* \$[{]
+ (?: (?:binary|source):(?:Upstream-)?Version
+ | Source-Version) [}] }xsm
+ ) {
+ $context = "$relevant[0], $relevant[1]";
+ }
+ }
+
+ $self->pointed_hint('weak-library-dev-dependency',
+ $pointer, "(in section for $installable)",
+ $field, $context)
+ if length $context;
+ }
+ }
+
+ return;
+}
+
+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/Lintian/Check/Debian/Control/Prerequisite/Redundant.pm b/lib/Lintian/Check/Debian/Control/Prerequisite/Redundant.pm
new file mode 100644
index 0000000..08ea510
--- /dev/null
+++ b/lib/Lintian/Check/Debian/Control/Prerequisite/Redundant.pm
@@ -0,0 +1,99 @@
+# debian/control/prerequisitie/redundant -- lintian check script -*- perl -*-
+#
+# Copyright (C) 2004 Marc Brockschmidt
+# Copyright (C) 2020 Chris Lamb <lamby@debian.org>
+# Copyright (C) 2020-2021 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 Lintian::Check::Debian::Control::Prerequisite::Redundant;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Const::Fast;
+
+use Moo;
+use namespace::clean;
+
+with 'Lintian::Check';
+
+const my $ARROW => q{->};
+
+sub source {
+ my ($self) = @_;
+
+ my $control = $self->processable->debian_control;
+
+ # Make sure that a stronger dependency field doesn't satisfy any of
+ # the elements of a weaker dependency field. dpkg-gencontrol will
+ # fix this up for us, but we want to check the source package
+ # since dpkg-gencontrol may silently "fix" something that's a more
+ # subtle bug.
+
+ # ordered from stronger to weaker
+ my @ordered_fields = qw(Pre-Depends Depends Recommends Suggests);
+
+ for my $installable ($control->installables) {
+ my $installable_fields = $control->installable_fields($installable);
+
+ my @remaining_fields = @ordered_fields;
+
+ for my $stronger (@ordered_fields) {
+
+ shift @remaining_fields;
+
+ next
+ unless $control->installable_fields($installable)
+ ->declares($stronger);
+
+ my $control_item= $self->processable->debian_control->item;
+ my $position = $installable_fields->position($stronger);
+ my $pointer = $control_item->pointer($position);
+
+ my $relation
+ = $self->processable->binary_relation($installable,$stronger);
+
+ for my $weaker (@remaining_fields) {
+
+ my @prerequisites = $control->installable_fields($installable)
+ ->trimmed_list($weaker, qr{\s*,\s*});
+
+ for my $prerequisite (@prerequisites) {
+
+ $self->pointed_hint(
+ 'redundant-installation-prerequisite',$pointer,
+ "(in section for $installable)",$weaker,
+ $ARROW, $stronger,
+ $prerequisite
+ )if $relation->satisfies($prerequisite);
+ }
+ }
+ }
+ }
+
+ return;
+}
+
+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/Lintian/Check/Debian/Copyright.pm b/lib/Lintian/Check/Debian/Copyright.pm
new file mode 100644
index 0000000..6eb8900
--- /dev/null
+++ b/lib/Lintian/Check/Debian/Copyright.pm
@@ -0,0 +1,586 @@
+# copyright -- lintian check script -*- perl -*-
+
+# Copyright (C) 1998 Christian Schwarz
+# Copyright (C) 1998 Richard Braakman
+# Copyright (C) 2011 Jakub Wilk
+# 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 Lintian::Check::Debian::Copyright;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Const::Fast;
+use List::SomeUtils qw(any all none uniq);
+use Path::Tiny;
+use Syntax::Keyword::Try;
+use Unicode::UTF8 qw(valid_utf8 decode_utf8 encode_utf8);
+
+use Lintian::Deb822;
+use Lintian::IPC::Run3 qw(safe_qx);
+use Lintian::Spelling qw(check_spelling);
+
+use Moo;
+use namespace::clean;
+
+with 'Lintian::Check';
+
+const my $EMPTY => q{};
+
+const my $APPROXIMATE_GPL_LENGTH => 12_000;
+const my $APPROXIMATE_GFDL_LENGTH => 12_000;
+const my $APPROXIMATE_APACHE_2_LENGTH => 10_000;
+
+sub spelling_tag_emitter {
+ my ($self, @orig_args) = @_;
+
+ return sub {
+ return $self->hint(@orig_args, @_);
+ };
+}
+
+sub source {
+ my ($self) = @_;
+
+ my $debian_dir = $self->processable->patched->resolve_path('debian/');
+ return
+ unless defined $debian_dir;
+
+ my @installables = $self->processable->debian_control->installables;
+ my @additional = map { $_ . '.copyright' } @installables;
+
+ my @candidates = ('copyright', @additional);
+ my @files = grep { defined } map { $debian_dir->child($_) } @candidates;
+
+ # look for <pkgname>.copyright for a single installable
+ if (@files == 1) {
+ my $single = $files[0];
+
+ $self->pointed_hint('named-copyright-for-single-installable',
+ $single->pointer)
+ unless $single->name eq 'debian/copyright';
+ }
+
+ $self->hint('no-debian-copyright-in-source')
+ unless @files;
+
+ my @symlinks = grep { $_->is_symlink } @files;
+ $self->pointed_hint('debian-copyright-is-symlink', $_->pointer)
+ for @symlinks;
+
+ return;
+}
+
+# no copyright in udebs
+sub binary {
+ my ($self) = @_;
+
+ my $package = $self->processable->name;
+
+ # looking up entry without slash first; index should not be so picky
+ my $doclink
+ = $self->processable->installed->lookup("usr/share/doc/$package");
+ if ($doclink && $doclink->is_symlink) {
+
+ # check if this symlink references a directory elsewhere
+ if ($doclink->link =~ m{^(?:\.\.)?/}s) {
+ $self->pointed_hint(
+ 'usr-share-doc-symlink-points-outside-of-usr-share-doc',
+ $doclink->pointer, $doclink->link);
+ return;
+ }
+
+ # The symlink may point to a subdirectory of another
+ # /usr/share/doc directory. This is allowed if this
+ # package depends on link and both packages come from the
+ # same source package.
+ #
+ # Policy requires that packages be built from the same
+ # source if they're going to do this, which by my (rra's)
+ # reading means that we should have a strict version
+ # dependency. However, in practice the copyright file
+ # doesn't change a lot and strict version dependencies
+ # cause other problems (such as with arch: any / arch: all
+ # package combinations and binNMUs).
+ #
+ # We therefore just require the dependency for now and
+ # don't worry about the version number.
+ my $link = $doclink->link;
+ $link =~ s{/.*}{};
+
+ unless ($self->depends_on($self->processable, $link)) {
+ $self->hint('usr-share-doc-symlink-without-dependency', $link);
+
+ return;
+ }
+
+ # Check if the link points to a package from the same source.
+ $self->check_cross_link($link);
+
+ return;
+ }
+
+ # now with a slash; indicates directory
+ my $docdir
+ = $self->processable->installed->lookup("usr/share/doc/$package/");
+ unless ($docdir) {
+ $self->hint('no-copyright-file');
+ return;
+ }
+
+ my $found = 0;
+ my $zipped = $docdir->child('copyright.gz');
+ if (defined $zipped) {
+
+ $self->pointed_hint('copyright-file-compressed', $zipped->pointer);
+ $found = 1;
+ }
+
+ my $linked = 0;
+
+ my $item = $docdir->child('copyright');
+ if (defined $item) {
+ $found = 1;
+
+ if ($item->is_symlink) {
+
+ $self->pointed_hint('copyright-file-is-symlink', $item->pointer);
+ $linked = 1;
+ # fall through; coll/copyright-file prevents reading through evil link
+ }
+ }
+
+ unless ($found) {
+
+ # #522827: special exception for perl for now
+ $self->hint('no-copyright-file')
+ unless $package eq 'perl';
+
+ return;
+ }
+
+ my $copyrigh_path;
+
+ my $uncompressed
+ = $self->processable->installed->resolve_path(
+ "usr/share/doc/$package/copyright");
+ $copyrigh_path = $uncompressed->unpacked_path
+ if defined $uncompressed;
+
+ my $compressed
+ = $self->processable->installed->resolve_path(
+ "usr/share/doc/$package/copyright.gz");
+ if (defined $compressed) {
+
+ my $bytes = safe_qx('gunzip', '-c', $compressed->unpacked_path);
+ my $contents = decode_utf8($bytes);
+
+ my $extracted
+ = path($self->processable->basedir)->child('copyright')->stringify;
+ path($extracted)->spew($contents);
+
+ $copyrigh_path = $extracted;
+ }
+
+ return
+ unless length $copyrigh_path;
+
+ my $bytes = path($copyrigh_path)->slurp;
+
+ # another check complains about invalid encoding
+ return
+ unless valid_utf8($bytes);
+
+ # check contents of copyright file
+ my $contents = decode_utf8($bytes);
+
+ $self->hint('copyright-has-crs')
+ if $contents =~ /\r/;
+
+ my $wrong_directory_detected = 0;
+
+ my $KNOWN_COMMON_LICENSES
+ = $self->data->load('copyright-file/common-licenses');
+
+ if ($contents =~ m{ (usr/share/common-licenses/ ( [^ \t]*? ) \.gz) }xsm) {
+ my ($path, $license) = ($1, $2);
+ if ($KNOWN_COMMON_LICENSES->recognizes($license)) {
+ $self->hint('copyright-refers-to-compressed-license', $path);
+ }
+ }
+
+ # Avoid complaining about referring to a versionless license file
+ # if the word "version" appears nowhere in the copyright file.
+ # This won't catch all of our false positives for GPL references
+ # that don't include a specific version number, but it will get
+ # the obvious ones.
+ if ($contents =~ m{(usr/share/common-licenses/(L?GPL|GFDL))([^-])}i) {
+ my ($ref, $license, $separator) = ($1, $2, $3);
+ if ($separator =~ /[\d\w]/) {
+ $self->hint('copyright-refers-to-nonexistent-license-file',
+ "$ref$separator");
+ } elsif ($contents =~ /\b(?:any|or)\s+later(?:\s+version)?\b/i
+ || $contents =~ /License: $license-[\d\.]+\+/i
+ || $contents =~ /as Perl itself/i
+ || $contents =~ /License-Alias:\s+Perl/
+ || $contents =~ /License:\s+Perl/) {
+ $self->hint('copyright-refers-to-symlink-license', $ref);
+ } else {
+ $self->hint('copyright-refers-to-versionless-license-file', $ref)
+ if $contents =~ /\bversion\b/;
+ }
+ }
+
+ # References to /usr/share/common-licenses/BSD are deprecated as of Policy
+ # 3.8.5.
+ if ($contents =~ m{/usr/share/common-licenses/BSD}) {
+ $self->hint('copyright-refers-to-deprecated-bsd-license-file');
+ }
+
+ if ($contents =~ m{(usr/share/common-licences)}) {
+ $self->hint('copyright-refers-to-incorrect-directory', $1);
+ $wrong_directory_detected = 1;
+ }
+
+ if ($contents =~ m{usr/share/doc/copyright}) {
+ $self->hint('copyright-refers-to-old-directory');
+ $wrong_directory_detected = 1;
+ }
+
+ if ($contents =~ m{usr/doc/copyright}) {
+ $self->hint('copyright-refers-to-old-directory');
+ $wrong_directory_detected = 1;
+ }
+
+ # Lame check for old FSF zip code. Try to avoid false positives from other
+ # Cambridge, MA addresses.
+ if ($contents =~ m/(?:Free\s*Software\s*Foundation.*02139|02111-1307)/s) {
+ $self->hint('old-fsf-address-in-copyright-file');
+ }
+
+ # Whether the package is covered by the GPL, used later for the
+ # libssl check.
+ my $gpl;
+
+ if (
+ length $contents > $APPROXIMATE_GPL_LENGTH
+ && (
+ $contents =~ m{ \b \QGNU GENERAL PUBLIC LICENSE\E \s*
+ \QTERMS AND CONDITIONS FOR COPYING,\E \s*
+ \QDISTRIBUTION AND MODIFICATION\E \b }msx
+ || (
+ $contents =~ m{ \b \QGNU GENERAL PUBLIC LICENSE\E
+ \s* \QVersion 3\E }msx
+ && $contents =~ m{ \b \QTERMS AND CONDITIONS\E \s }msx
+ )
+ )
+ ) {
+ $self->hint('copyright-file-contains-full-gpl-license');
+ $gpl = 1;
+ }
+
+ if (
+ length $contents > $APPROXIMATE_GFDL_LENGTH
+ && $contents =~ m{ \b \QGNU Free Documentation License\E
+ \s* \QVersion 1.2\E }msx
+ && $contents =~ m{ \b \Q1. APPLICABILITY AND DEFINITIONS\E }msx
+ ) {
+
+ $self->hint('copyright-file-contains-full-gfdl-license');
+ }
+
+ if ( length $contents > $APPROXIMATE_APACHE_2_LENGTH
+ && $contents =~ m{ \b \QApache License\E \s+ \QVersion 2.0,\E }msx
+ && $contents
+ =~ m{ \QTERMS AND CONDITIONS FOR USE, REPRODUCTION, AND DISTRIBUTION\E }msx
+ ) {
+
+ $self->hint('copyright-file-contains-full-apache-2-license');
+ }
+
+ # wtf?
+ if ( ($contents =~ m{common-licenses(/\S+)})
+ && ($contents !~ m{/usr/share/common-licenses/})) {
+ $self->hint('copyright-does-not-refer-to-common-license-file', $1);
+ }
+
+ # This check is a bit prone to false positives, since some other
+ # licenses mention the GPL. Also exclude any mention of the GPL
+ # following what looks like mail header fields, since sometimes
+ # e-mail discussions of licensing are included in the copyright
+ # file but aren't referring to the license of the package.
+ unless (
+ $contents =~ m{/usr/share/common-licenses}
+ || $contents =~ m/Zope Public License/
+ || $contents =~ m/LICENSE AGREEMENT FOR PYTHON 1.6.1/
+ || $contents =~ m/LaTeX Project Public License/
+ || $contents
+ =~ m/(?:^From:.*^To:|^To:.*^From:).*(?:GNU General Public License|GPL)/ms
+ || $contents =~ m/AFFERO GENERAL PUBLIC LICENSE/
+ || $contents =~ m/GNU Free Documentation License[,\s]*Version 1\.1/
+ || $contents =~ m/CeCILL FREE SOFTWARE LICENSE AGREEMENT/ #v2.0
+ || $contents =~ m/FREE SOFTWARE LICENSING AGREEMENT CeCILL/ #v1.1
+ || $contents =~ m/CNRI OPEN SOURCE GPL-COMPATIBLE LICENSE AGREEMENT/
+ || $contents =~ m/compatible\s+with\s+(?:the\s+)?(?:GNU\s+)?GPL/
+ || $contents =~ m/(?:GNU\s+)?GPL\W+compatible/
+ || $contents
+ =~ m/was\s+previously\s+(?:distributed\s+)?under\s+the\s+GNU/
+ || $contents
+ =~ m/means\s+either\s+the\s+GNU\s+General\s+Public\s+License/
+ || $wrong_directory_detected
+ ) {
+ if (
+ check_names_texts(
+ $contents,
+ qr/\b(?:GFDL|gnu[-_]free[-_]documentation[-_]license)\b/i,
+ qr/GNU Free Documentation License|(?-i:\bGFDL\b)/i
+ )
+ ) {
+ $self->hint('copyright-not-using-common-license-for-gfdl');
+ }elsif (
+ check_names_texts(
+ $contents,
+qr/\b(?:LGPL|gnu[-_](?:lesser|library)[-_]general[-_]public[-_]license)\b/i,
+qr/GNU (?:Lesser|Library) General Public License|(?-i:\bLGPL\b)/i
+ )
+ ) {
+ $self->hint('copyright-not-using-common-license-for-lgpl');
+ }elsif (
+ check_names_texts(
+ $contents,
+ qr/\b(?:GPL|gnu[-_]general[-_]public[-_]license)\b/i,
+ qr/GNU General Public License|(?-i:\bGPL\b)/i
+ )
+ ) {
+ $self->hint('copyright-not-using-common-license-for-gpl');
+ $gpl = 1;
+ }elsif (
+ check_names_texts(
+ $contents,qr/\bapache[-_]2/i,
+ qr/\bApache License\s*,?\s*Version 2|\b(?-i:Apache)-2/i
+ )
+ ) {
+ $self->hint('copyright-not-using-common-license-for-apache2');
+ }
+ }
+
+ if (
+ check_names_texts(
+ $contents,
+ qr/\b(?:perl|artistic)\b/,
+ sub {
+ my ($text) = @_;
+ $text
+ =~ /(?:under )?(?:the )?(?:same )?(?:terms )?as Perl itself\b/i
+ && $text !~ m{usr/share/common-licenses/};
+ }
+ )
+ ) {
+ $self->hint('copyright-file-lacks-pointer-to-perl-license');
+ }
+
+ # Checks for various packaging helper boilerplate.
+
+ $self->hint('helper-templates-in-copyright')
+ if $contents =~ m{<fill in (?:http/)?ftp site>}
+ || $contents =~ /<Must follow here>/
+ || $contents =~ /<Put the license of the package here/
+ || $contents =~ /<put author[\'\(]s\)? name and email here>/
+ || $contents =~ /<Copyright \(C\) YYYY Name OfAuthor>/
+ || $contents =~ /Upstream Author\(s\)/
+ || $contents =~ /<years>/
+ || $contents =~ /<special license>/
+ || $contents
+ =~ /<Put the license of the package here indented by 1 space>/
+ || $contents
+ =~ /<This follows the format of Description: lines\s*in control file>/
+ || $contents =~ /<Including paragraphs>/
+ || $contents =~ /<likewise for another author>/;
+
+ # dh-make-perl
+ $self->hint('copyright-contains-automatically-extracted-boilerplate')
+ if $contents =~ /This copyright info was automatically extracted/;
+
+ $self->hint('helper-templates-in-copyright')
+ if $contents =~ /<INSERT COPYRIGHT YEAR\(S\) HERE>/;
+
+ $self->hint('copyright-has-url-from-dh_make-boilerplate')
+ if $contents =~ m{url://};
+
+ # dh-make boilerplate
+ my @dh_make_boilerplate = (
+"# Please also look if there are files or directories which have a\n# different copyright/license attached and list them here.",
+"# If you want to use GPL v2 or later for the /debian/* files use\n# the following clauses, or change it to suit. Delete these two lines"
+ );
+
+ $self->hint('copyright-contains-dh_make-todo-boilerplate')
+ if any { $contents =~ /$_/ } @dh_make_boilerplate;
+
+ $self->hint('copyright-with-old-dh-make-debian-copyright')
+ if $contents =~ /The\s+Debian\s+packaging\s+is\s+\(C\)\s+\d+/i;
+
+ # Other flaws in the copyright phrasing or contents.
+ if ($found && !$linked) {
+ $self->hint('copyright-without-copyright-notice')
+ unless $contents
+ =~ m{(?:Copyright|Copr\.|\N{COPYRIGHT SIGN})(?:.*|[\(C\):\s]+)\b\d{4}\b
+ |\bpublic(?:\s+|-)domain\b}xi;
+ }
+
+ check_spelling(
+ $self->data,$contents,
+ $self->group->spelling_exceptions,
+ $self->spelling_tag_emitter('spelling-error-in-copyright'), 0
+ );
+
+ # Now, check for linking against libssl if the package is covered
+ # by the GPL. (This check was requested by ftp-master.) First,
+ # see if the package is under the GPL alone and try to exclude
+ # packages with a mix of GPL and LGPL or Artistic licensing or
+ # with an exception or exemption.
+ if (($gpl || $contents =~ m{/usr/share/common-licenses/GPL})
+ &&$contents
+ !~ m{exception|exemption|/usr/share/common-licenses/(?!GPL)\S}){
+
+ my @depends
+ = split(/\s*,\s*/,$self->processable->fields->value('Depends'));
+ my @predepends
+ = split(/\s*,\s*/,$self->processable->fields->value('Pre-Depends'));
+
+ $self->hint('possible-gpl-code-linked-with-openssl')
+ if any { /^libssl[0-9.]+(?:\s|\z)/ && !/\|/ }(@depends, @predepends);
+ }
+
+ return;
+} # </run>
+
+# -----------------------------------
+
+# Returns true if the package whose information is in $processable depends $package
+# or if $package is essential.
+sub depends_on {
+ my ($self, $processable, $package) = @_;
+
+ my $KNOWN_ESSENTIAL = $self->data->load('fields/essential');
+
+ return 1
+ if $KNOWN_ESSENTIAL->recognizes($package);
+
+ my $strong = $processable->relation('strong');
+ return 1
+ if $strong->satisfies($package);
+
+ my $arch = $processable->architecture;
+ return 1
+ if $arch ne 'all' and $strong->satisfies("${package}:${arch}");
+
+ return 0;
+}
+
+# Checks cross pkg links for /usr/share/doc/$pkg links
+sub check_cross_link {
+ my ($self, $foreign) = @_;
+
+ my $source = $self->group->source;
+ if ($source) {
+
+ # source package is available; check its list of binaries
+ return
+ if any { $foreign eq $_ } $source->debian_control->installables;
+
+ $self->hint('usr-share-doc-symlink-to-foreign-package', $foreign);
+
+ } else {
+ # The source package is not available, but the binary could
+ # be present anyway; If they are in the same group, they claim
+ # to have the same source (and source version)
+ return
+ if any { $_->name eq $foreign }$self->group->get_installables;
+
+ # It was not, but since the source package was not present, we cannot
+ # tell if it is foreign or not at this point.
+
+ $self->hint(
+'cannot-check-whether-usr-share-doc-symlink-points-to-foreign-package'
+ );
+ }
+
+ return;
+}
+
+# Checks the name and text of every license in the file against given name and
+# text check coderefs, if the file is in the new format, if the file is in the
+# old format only runs the text coderef against the whole file.
+sub check_names_texts {
+ my ($contents, $name_check, $action) = @_;
+
+ my $text_check;
+
+ if ((ref($action) || $EMPTY) eq 'Regexp') {
+ $text_check = sub {
+ my ($textref) = @_;
+ return ${$textref} =~ $action;
+ };
+
+ } else {
+ $text_check = sub {
+ my ($textref) = @_;
+ return $action->(${$textref});
+ };
+ }
+
+ my $deb822 = Lintian::Deb822->new;
+
+ my @paragraphs;
+ try {
+ @paragraphs = $deb822->parse_string($contents);
+
+ } catch {
+ # parse error: copyright not in new format, just check text
+ return $text_check->(\$contents);
+ }
+
+ my @licenses = grep { length } map { $_->value('License') } @paragraphs;
+ for my $license (@licenses) {
+
+ my ($name, $text) = ($license =~ /^\s*([^\r\n]+)\r?\n(.*)\z/s);
+
+ next
+ unless length $text;
+
+ next
+ if $text =~ /^[\s\r\n]*\z/;
+
+ return 1
+ if $name =~ $name_check
+ && $text_check->(\$text);
+ }
+
+ # did not match anything
+ return 0;
+}
+
+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/Lintian/Check/Debian/Copyright/ApacheNotice.pm b/lib/Lintian/Check/Debian/Copyright/ApacheNotice.pm
new file mode 100644
index 0000000..72e91b4
--- /dev/null
+++ b/lib/Lintian/Check/Debian/Copyright/ApacheNotice.pm
@@ -0,0 +1,105 @@
+# debian/copyright/apache-notice -- lintian check script -*- perl -*-
+
+# Copyright (C) 1998 Christian Schwarz
+# Copyright (C) 2011 Jakub Wilk
+# 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 Lintian::Check::Debian::Copyright::ApacheNotice;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Const::Fast;
+use List::SomeUtils qw(any);
+
+use Moo;
+use namespace::clean;
+
+with 'Lintian::Check';
+
+const my $SPACE => q{ };
+
+sub source {
+ my ($self) = @_;
+
+ my $debian_dir = $self->processable->patched->resolve_path('debian/');
+ return
+ unless defined $debian_dir;
+
+ my @installables = $self->processable->debian_control->installables;
+ my @additional = map { $_ . '.copyright' } @installables;
+
+ my @candidates = ('copyright', @additional);
+ my @files = grep { defined } map { $debian_dir->child($_) } @candidates;
+
+ # another check complains about legacy encoding, if needed
+ my @valid_utf8 = grep { $_->is_valid_utf8 } @files;
+
+ $self->check_apache_notice_files($_)for @valid_utf8;
+
+ return;
+}
+
+sub check_apache_notice_files {
+ my ($self, $file) = @_;
+
+ my $contents = $file->decoded_utf8;
+ return
+ unless $contents =~ /apache[-\s]+2\./i;
+
+ my @notice_files = grep {
+ $_->basename =~ /^NOTICE(\.txt)?$/
+ and $_->is_open_ok
+ and $_->bytes =~ /apache/i
+ } @{$self->processable->patched->sorted_list};
+ return
+ unless @notice_files;
+
+ my @binaries = grep { $_->type ne 'udeb' } $self->group->get_installables;
+ return
+ unless @binaries;
+
+ for my $binary (@binaries) {
+
+ # look at all path names in the package
+ my @names = map { $_->name } @{$binary->installed->sorted_list};
+
+ # and also those shipped in jars
+ my @jars = grep { scalar keys %{$_->java_info} }
+ @{$binary->installed->sorted_list};
+ push(@names, keys %{$_->java_info->{files}})for @jars;
+
+ return
+ if any { m{/NOTICE(\.txt)?(\.gz)?$} } @names;
+ }
+
+ $self->pointed_hint('missing-notice-file-for-apache-license', $_->pointer)
+ for @notice_files;
+
+ return;
+}
+
+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/Lintian/Check/Debian/Copyright/Dep5.pm b/lib/Lintian/Check/Debian/Copyright/Dep5.pm
new file mode 100644
index 0000000..1084de8
--- /dev/null
+++ b/lib/Lintian/Check/Debian/Copyright/Dep5.pm
@@ -0,0 +1,968 @@
+# debian/copyright/dep5 -- lintian check script -*- perl -*-
+
+# Copyright (C) 1998 Christian Schwarz
+# Copyright (C) 2011 Jakub Wilk
+# 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 Lintian::Check::Debian::Copyright::Dep5;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Const::Fast;
+use List::Compare;
+use List::SomeUtils qw(any all none uniq);
+use Syntax::Keyword::Try;
+use Regexp::Wildcards;
+use Time::Piece;
+use XML::LibXML;
+
+use Lintian::Deb822;
+use Lintian::Relation::Version qw(versions_compare);
+use Lintian::Util qw(match_glob);
+
+use Moo;
+use namespace::clean;
+
+with 'Lintian::Check';
+
+const my $LAST_SIGNIFICANT_DEP5_CHANGE => '0+svn~166';
+const my $LAST_DEP5_OVERHAUL => '0+svn~148';
+
+const my $EMPTY => q{};
+const my $SPACE => q{ };
+const my $SLASH => q{/};
+const my $COLON => q{:};
+const my $HYPHEN => q{-};
+const my $ASTERISK => q{*};
+
+const my $MINIMUM_CREATIVE_COMMMONS_LENGTH => 20;
+const my $LAST_ITEM => -1;
+
+const my %NEW_FIELD_NAMES => (
+ 'Format-Specification' => 'Format',
+ 'Maintainer' => 'Upstream-Contact',
+ 'Upstream-Maintainer' => 'Upstream-Contact',
+ 'Contact' => 'Upstream-Contact',
+ 'Name' => 'Upstream-Name',
+);
+
+sub source {
+ my ($self) = @_;
+
+ my $debian_dir = $self->processable->patched->resolve_path('debian/');
+ return
+ unless defined $debian_dir;
+
+ my @installables = $self->processable->debian_control->installables;
+ my @additional = map { $_ . '.copyright' } @installables;
+
+ my @candidates = ('copyright', @additional);
+ my @files = grep { defined $_ && !$_->is_symlink }
+ map { $debian_dir->child($_) } @candidates;
+
+ # another check complains about legacy encoding, if needed
+ my @valid_utf8 = grep { $_->is_valid_utf8 } @files;
+
+ $self->check_dep5_copyright($_) for @valid_utf8;
+
+ return;
+}
+
+# The policy states, since 4.0.0, that people should use "https://" for the
+# format URI. This is checked later in check_dep5_copyright.
+# return undef is not dep5 and '' if unknown version
+sub find_dep5_version {
+ my ($self, $file, $original_uri) = @_;
+
+ my $uri = $original_uri;
+ my $version;
+
+ if ($uri =~ /\b(?:rev=REVISION|VERSIONED_FORMAT_URL)\b/) {
+
+ $self->pointed_hint('boilerplate-copyright-format-uri',
+ $file->pointer,$uri);
+ return undef;
+ }
+
+ if (
+ $uri =~ s{ https?://wiki\.debian\.org/
+ Proposals/CopyrightFormat\b}{}xsm
+ ){
+ $version = '0~wiki';
+
+ $version = "$version~$1"
+ if $uri =~ /^\?action=recall&rev=(\d+)$/;
+
+ return $version;
+ }
+
+ if ($uri =~ m{^https?://dep(-team\.pages)?\.debian\.net/deps/dep5/?$}) {
+
+ $version = '0+svn';
+ return $version;
+ }
+
+ if (
+ $uri =~ s{\A https?://svn\.debian\.org/
+ wsvn/dep/web/deps/dep5\.mdwn\b}{}xsm
+ ){
+ $version = '0+svn';
+
+ $version = "$version~$1"
+ if $uri =~ /^\?(?:\S+[&;])?rev=(\d+)(?:[&;]\S+)?$/;
+
+ return $version;
+ }
+ if (
+ $uri =~ s{ \A https?://(?:svn|anonscm)\.debian\.org/
+ viewvc/dep/web/deps/dep5\.mdwn\b}{}xsm
+ ){
+ $version = '0+svn';
+ $uri =~ m{\A \? (?:\S+[&;])?
+ (?:pathrev|revision|rev)=(\d+)(?:[&;]\S+)?
+ \Z}xsm
+ and $version = "$version~$1";
+ return $version;
+ }
+ if (
+ $uri =~ m{ \A
+ https?://www\.debian\.org/doc/
+ (?:packaging-manuals/)?copyright-format/(\d+\.\d+)/?
+ \Z}xsm
+ ){
+ $version = $1;
+ return $version;
+ }
+
+ $self->pointed_hint('unknown-copyright-format-uri',
+ $file->pointer, $original_uri);
+
+ return undef;
+}
+
+sub check_dep5_copyright {
+ my ($self, $copyright_file) = @_;
+
+ my $contents = $copyright_file->decoded_utf8;
+
+ if ($contents =~ /^Files-Excluded:/m) {
+
+ if ($contents
+ =~ m{^Format:.*/doc/packaging-manuals/copyright-format/1.0/?$}m) {
+
+ $self->pointed_hint('repackaged-source-not-advertised',
+ $copyright_file->pointer)
+ unless $self->processable->repacked
+ || $self->processable->native;
+
+ } else {
+ $self->pointed_hint('files-excluded-without-copyright-format-1.0',
+ $copyright_file->pointer);
+ }
+ }
+
+ unless (
+ $contents =~ m{
+ (?:^ | \n)
+ (?i: format(?: [:] |[-\s]spec) )
+ (?: . | \n\s+ )*
+ (?: /dep[5s]?\b | \bDEP ?5\b
+ | [Mm]achine-readable\s(?:license|copyright)
+ | /copyright-format/ | CopyrightFormat
+ | VERSIONED_FORMAT_URL
+ ) }x
+ ){
+
+ $self->pointed_hint('no-dep5-copyright', $copyright_file->pointer);
+ return;
+ }
+
+ # get format before parsing as a debian control file
+ my $first_para = $contents;
+ $first_para =~ s/^#.*//mg;
+ $first_para =~ s/[ \t]+$//mg;
+ $first_para =~ s/^\n+//g;
+ $first_para =~ s/\n\n.*/\n/s; #;; hi emacs
+ $first_para =~ s/\n?[ \t]+/ /g;
+
+ if ($first_para !~ /^Format(?:-Specification)?:\s*(\S+)\s*$/mi) {
+ $self->pointed_hint('unknown-copyright-format-uri',
+ $copyright_file->pointer);
+ return;
+ }
+
+ my $uri = $1;
+
+ # strip fragment identifier
+ $uri =~ s/^([^#\s]+)#/$1/;
+
+ my $version = $self->find_dep5_version($copyright_file, $uri);
+ return
+ unless defined $version;
+
+ if ($version =~ /wiki/) {
+ $self->pointed_hint('wiki-copyright-format-uri',
+ $copyright_file->pointer, $uri);
+
+ } elsif ($version =~ /svn$/) {
+ $self->pointed_hint('unversioned-copyright-format-uri',
+ $copyright_file->pointer, $uri);
+
+ } elsif (versions_compare($version, '<<', $LAST_SIGNIFICANT_DEP5_CHANGE)) {
+ $self->pointed_hint('out-of-date-copyright-format-uri',
+ $copyright_file->pointer, $uri);
+
+ } elsif ($uri =~ m{^http://www\.debian\.org/}) {
+ $self->pointed_hint('insecure-copyright-format-uri',
+ $copyright_file->pointer, $uri);
+ }
+
+ return
+ if versions_compare($version, '<<', $LAST_DEP5_OVERHAUL);
+
+ # probably DEP 5 format; let's try more checks
+ my $deb822 = Lintian::Deb822->new;
+
+ my @sections;
+ try {
+ @sections = $deb822->read_file($copyright_file->unpacked_path);
+
+ } catch {
+ my $error = $@;
+ chomp $error;
+ $error =~ s{^syntax error in }{};
+
+ $self->pointed_hint('syntax-error-in-dep5-copyright',
+ $copyright_file->pointer, $@);
+
+ return;
+ }
+
+ return
+ unless @sections;
+
+ my %found_standalone;
+ my %license_names_by_section;
+ my %license_text_by_section;
+ my %license_identifier_by_section;
+
+ my @license_sections = grep { $_->declares('License') } @sections;
+ for my $section (@license_sections) {
+
+ my $position = $section->position('License');
+ my $pointer = $copyright_file->pointer($position);
+
+ $self->pointed_hint('tab-in-license-text', $pointer)
+ if $section->untrimmed_value('License') =~ /\t/;
+
+ my ($anycase_identifier, $license_text)
+ = split(/\n/, $section->untrimmed_value('License'), 2);
+
+ $anycase_identifier //= $EMPTY;
+ $license_text //= $EMPTY;
+
+ # replace some weird characters
+ $anycase_identifier =~ s/[(),]/ /g;
+
+ # trim both ends
+ $anycase_identifier =~ s/^\s+|\s+$//g;
+ $license_text =~ s/^\s+|\s+$//g;
+
+ my $license_identifier = lc $anycase_identifier;
+
+ my @license_names
+ = grep { length } split(/\s+(?:and|or)\s+/, $license_identifier);
+
+ $license_names_by_section{$section->position} = \@license_names;
+ $license_text_by_section{$section->position} = $license_text;
+ $license_identifier_by_section{$section->position}
+ = $license_identifier;
+
+ $self->pointed_hint('empty-short-license-in-dep5-copyright', $pointer)
+ unless length $license_identifier;
+
+ $self->pointed_hint('pipe-symbol-used-as-license-disjunction',
+ $pointer, $license_identifier)
+ if $license_identifier =~ m{\s+\|\s+};
+
+ for my $name (@license_names) {
+ if ($name =~ /\s/) {
+
+ if($name =~ /[^ ]+ \s+ with \s+ (.*)/x) {
+
+ my $exceptiontext = $1;
+
+ $self->pointed_hint(
+ 'bad-exception-format-in-dep5-copyright',
+ $pointer, $name)
+ unless $exceptiontext =~ /[^ ]+ \s+ exception/x;
+
+ } else {
+
+ $self->pointed_hint(
+ 'space-in-std-shortname-in-dep5-copyright',
+ $pointer, $name);
+ }
+ }
+
+ $self->pointed_hint('invalid-short-name-in-dep5-copyright',
+ $pointer, $name)
+ if $name =~ m{^(?:agpl|gpl|lgpl)[^-]?\d(?:\.\d)?\+?$}
+ || $name =~ m{^bsd(?:[^-]?[234][^-]?(?:clause|cluase))?$};
+
+ $self->pointed_hint('license-problem-undefined-license',
+ $pointer, $name)
+ if $name eq $HYPHEN
+ || $name
+ =~ m{\b(?:fixmes?|todos?|undefined?|unknown?|unspecified)\b};
+ }
+
+ # stand-alone license
+ if ( length $license_identifier
+ && length $license_text
+ && !$section->declares('Files')) {
+
+ $found_standalone{$license_identifier} //= [];
+ push(@{$found_standalone{$license_identifier}}, $section);
+ }
+
+ if ($license_identifier =~ /^cc-/ && length $license_text) {
+
+ my $num_lines = $license_text =~ tr/\n//;
+
+ $self->pointed_hint('incomplete-creative-commons-license',
+ $pointer, $license_identifier)
+ if $num_lines < $MINIMUM_CREATIVE_COMMMONS_LENGTH;
+ }
+ }
+
+ my @not_unique
+ = grep { @{$found_standalone{$_}} > 1 } keys %found_standalone;
+ for my $name (@not_unique) {
+
+ next
+ if $name eq 'public-domain';
+
+ for my $section (@{$found_standalone{$name}}) {
+
+ my $position = $section->position('License');
+ my $pointer = $copyright_file->pointer($position);
+
+ $self->pointed_hint('dep5-copyright-license-name-not-unique',
+ $pointer, $name);
+ }
+ }
+
+ my ($header, @followers) = @sections;
+
+ my @obsolete_fields = grep { $header->declares($_) } keys %NEW_FIELD_NAMES;
+ for my $old_name (@obsolete_fields) {
+
+ my $position = $header->position($old_name);
+ my $pointer = $copyright_file->pointer($position);
+
+ $self->pointed_hint('obsolete-field-in-dep5-copyright',
+ $pointer, $old_name, $NEW_FIELD_NAMES{$old_name});
+ }
+
+ my $header_pointer = $copyright_file->pointer($header->position);
+
+ $self->pointed_hint('missing-field-in-dep5-copyright',
+ $header_pointer, 'Format')
+ if none { $header->declares($_) } qw(Format Format-Specification);
+
+ my $debian_control = $self->processable->debian_control;
+
+ $self->pointed_hint('missing-explanation-for-contrib-or-non-free-package',
+ $header_pointer)
+ if $debian_control->source_fields->value('Section')
+ =~ m{^(?:contrib|non-free)(?:/.+)?$}
+ && (none { $header->declares($_) } qw{Comment Disclaimer});
+
+ $self->pointed_hint('missing-explanation-for-repacked-upstream-tarball',
+ $header_pointer)
+ if $self->processable->repacked
+ && $header->value('Source') =~ m{^https?://}
+ && (none { $header->declares($_) } qw{Comment Files-Excluded});
+
+ my @ambiguous_sections = grep {
+ $_->declares('License')
+ && $_->declares('Copyright')
+ && !$_->declares('Files')
+ } @followers;
+
+ $self->pointed_hint(
+ 'ambiguous-paragraph-in-dep5-copyright',
+ $copyright_file->pointer($_->position)
+ )for @ambiguous_sections;
+
+ my @unknown_sections
+ = grep {!$_->declares('License')&& !$_->declares('Files')} @followers;
+
+ $self->pointed_hint(
+ 'unknown-paragraph-in-dep5-copyright',
+ $copyright_file->pointer($_->position)
+ )for @unknown_sections;
+
+ my @shipped_items;
+
+ if ($self->processable->native) {
+ @shipped_items = @{$self->processable->patched->sorted_list};
+
+ } else {
+ @shipped_items = @{$self->processable->orig->sorted_list};
+
+ # remove ./debian folder from orig, if any
+ @shipped_items = grep { !m{^debian/} } @shipped_items
+ if $self->processable->fields->value('Format') eq '3.0 (quilt)';
+
+ # add ./ debian folder from patched
+ my $debian_dir = $self->processable->patched->resolve_path('debian/');
+ push(@shipped_items, $debian_dir->descendants)
+ if $debian_dir;
+ }
+
+ my @shipped_names
+ = sort map { $_->name } grep { $_->is_file } @shipped_items;
+
+ my @excluded;
+ for my $wildcard ($header->trimmed_list('Files-Excluded')) {
+
+ my $position = $header->position('Files-Excluded');
+ my $pointer = $copyright_file->pointer($position);
+
+ my @offenders = escape_errors($wildcard);
+
+ $self->pointed_hint('invalid-escape-sequence-in-dep5-copyright',
+ $pointer, '(Files-Excluded)', $_)
+ for @offenders;
+
+ next
+ if @offenders;
+
+ # also match dir/filename for Files-Excluded: dir
+ unless ($wildcard =~ /\*/ || $wildcard =~ /\?/) {
+
+ my $candidate = $wildcard;
+ $candidate .= $SLASH
+ unless $candidate =~ m{/$};
+
+ my $item = $self->processable->orig->lookup($candidate);
+
+ $wildcard = $candidate . $ASTERISK
+ if defined $item && $item->is_dir;
+ }
+
+ my @match = match_glob($wildcard, @shipped_names);
+
+ # do not flag missing matches; uscan already excluded them
+ push(@excluded, @match);
+ }
+
+ my @included;
+ for my $wildcard ($header->trimmed_list('Files-Included')) {
+
+ my $position = $header->position('Files-Included');
+ my $pointer = $copyright_file->pointer($position);
+
+ my @offenders = escape_errors($wildcard);
+
+ $self->pointed_hint('invalid-escape-sequence-in-dep5-copyright',
+ $pointer, '(Files-Included)', $_)
+ for @offenders;
+
+ next
+ if @offenders;
+
+ # also match dir/filename for Files-Excluded: dir
+ unless ($wildcard =~ /\*/ || $wildcard =~ /\?/) {
+
+ my $candidate = $wildcard;
+ $candidate .= $SLASH
+ unless $candidate =~ m{/$};
+
+ my $item = $self->processable->orig->lookup($candidate);
+
+ $wildcard = $candidate . $ASTERISK
+ if defined $item && $item->is_dir;
+ }
+
+ my @match = match_glob($wildcard, @shipped_names);
+
+ $self->pointed_hint(
+ 'superfluous-file-pattern', $pointer,
+ '(Files-Included)', $wildcard
+ )unless @match;
+
+ push(@included, @match);
+ }
+
+ my $lc = List::Compare->new(\@included, \@excluded);
+ my @affirmed = $lc->get_Lonly;
+ my @unwanted = $lc->get_Ronly;
+
+ # already unique
+ for my $name (@affirmed) {
+
+ my $position = $header->position('Files-Included');
+ my $pointer = $copyright_file->pointer($position);
+
+ $self->pointed_hint('file-included-already', $pointer, $name);
+ }
+
+ # already unique
+ for my $name (@unwanted) {
+
+ my $position = $header->position('Files-Excluded');
+ my $pointer = $copyright_file->pointer($position);
+
+ $self->pointed_hint('source-ships-excluded-file',$pointer, $name)
+ unless $name =~ m{^(?:debian|\.pc)/};
+ }
+
+ my @notice_names= grep { m{(^|/)(COPYING[^/]*|LICENSE)$} } @shipped_names;
+ my @quilt_names = grep { m{^\.pc/} } @shipped_names;
+
+ my @names_with_comma = grep { /,/ } @shipped_names;
+ my @fields_with_comma = grep { $_->value('Files') =~ /,/ } @followers;
+
+ for my $section (@fields_with_comma) {
+
+ my $position = $section->position('Files');
+ my $pointer = $copyright_file->pointer($position);
+
+ $self->pointed_hint('comma-separated-files-in-dep5-copyright',$pointer)
+ if !@names_with_comma;
+ }
+
+ # only attempt to evaluate globbing if commas could be legal
+ my $check_wildcards = !@fields_with_comma || @names_with_comma;
+
+ my @files_sections = grep {$_->declares('Files')} @followers;
+
+ for my $section (@files_sections) {
+
+ if (!length $section->value('Files')) {
+
+ my $position = $section->position('Files');
+ my $pointer = $copyright_file->pointer($position);
+
+ $self->pointed_hint('missing-field-in-dep5-copyright',
+ $pointer,'(empty field)', 'Files');
+ }
+
+ my $section_pointer = $copyright_file->pointer($section->position);
+
+ $self->pointed_hint('missing-field-in-dep5-copyright',
+ $section_pointer, 'License')
+ if !$section->declares('License');
+
+ $self->pointed_hint('missing-field-in-dep5-copyright',
+ $section_pointer, 'Copyright')
+ if !$section->declares('Copyright');
+
+ if ($section->declares('Copyright')
+ && !length $section->value('Copyright')) {
+
+ my $position = $section->position('Copyright');
+ my $pointer = $copyright_file->pointer($position);
+
+ $self->pointed_hint('missing-field-in-dep5-copyright',
+ $pointer, '(empty field)', 'Copyright');
+ }
+ }
+
+ my %sections_by_wildcard;
+ my %wildcard_by_file;
+ my %required_standalone;
+ my %positions_by_debian_year;
+ my @redundant_wildcards;
+
+ my $section_count = 0;
+ for my $section (@followers) {
+
+ my $wildcard_pointer
+ = $copyright_file->pointer($section->position('Files'));
+
+ my $copyright_pointer
+ = $copyright_file->pointer($section->position('Copyright'));
+
+ my $license_pointer
+ = $copyright_file->pointer($section->position('License'));
+
+ my @license_names
+ = @{$license_names_by_section{$section->position} // []};
+ my $license_text = $license_text_by_section{$section->position};
+
+ if ($section->declares('Files') && !length $license_text) {
+ $required_standalone{$_} = $section for @license_names;
+ }
+
+ my @wildcards;
+
+ # If it is the first paragraph, it might be an instance of
+ # the (no-longer) optional "first Files-field".
+ if ( $section_count == 0
+ && $section->declares('License')
+ && $section->declares('Copyright')
+ && !$section->declares('Files')) {
+
+ @wildcards = ($ASTERISK);
+
+ } else {
+ @wildcards = $section->trimmed_list('Files');
+ }
+
+ my @rightholders = $section->trimmed_list('Copyright', qr{ \n }x);
+ my @years = map { /(\d{4})/g } @rightholders;
+
+ if (any { m{^ debian (?: / | $) }x } @wildcards) {
+
+ my $position = $section->position('Copyright');
+
+ push(@{$positions_by_debian_year{$_}}, $position)for @years;
+ }
+
+ for my $wildcard (@wildcards) {
+ $sections_by_wildcard{$wildcard} //= [];
+ push(@{$sections_by_wildcard{$wildcard}}, $section);
+ }
+
+ $self->pointed_hint(
+ 'global-files-wildcard-not-first-paragraph-in-dep5-copyright',
+ $wildcard_pointer)
+ if (any { $_ eq $ASTERISK } @wildcards) && $section_count > 0;
+
+ # stand-alone license paragraph
+ $self->pointed_hint('missing-license-text-in-dep5-copyright',
+ $license_pointer, $section->untrimmed_value('License'))
+ if !@wildcards
+ && $section->declares('License')
+ && !length $license_text;
+
+ next
+ unless $check_wildcards;
+
+ my %wildcards_same_section_by_file;
+
+ for my $wildcard (@wildcards) {
+
+ my @offenders = escape_errors($wildcard);
+
+ $self->pointed_hint('invalid-escape-sequence-in-dep5-copyright',
+ $wildcard_pointer, $_)
+ for @offenders;
+
+ next
+ if @offenders;
+
+ my @covered = match_glob($wildcard, @shipped_names);
+
+ for my $name (@covered) {
+ $wildcards_same_section_by_file{$name} //= [];
+ push(@{$wildcards_same_section_by_file{$name}}, $wildcard);
+ }
+ }
+
+ my @overwritten = grep { length $wildcard_by_file{$_} }
+ keys %wildcards_same_section_by_file;
+
+ for my $name (@overwritten) {
+
+ my $winning_wildcard
+ = @{$wildcards_same_section_by_file{$name}}[$LAST_ITEM];
+ my $loosing_wildcard = $wildcard_by_file{$name};
+
+ my $winner_depth = ($winning_wildcard =~ tr{/}{});
+ my $looser_depth = ($loosing_wildcard =~ tr{/}{});
+
+ $self->pointed_hint('globbing-patterns-out-of-order',
+ $wildcard_pointer,$loosing_wildcard, $winning_wildcard, $name)
+ if $looser_depth > $winner_depth;
+ }
+
+ # later matches have precendence; depends on section ordering
+ $wildcard_by_file{$_}
+ = @{$wildcards_same_section_by_file{$_}}[$LAST_ITEM]
+ for keys %wildcards_same_section_by_file;
+
+ my @overmatched_same_section
+ = grep { @{$wildcards_same_section_by_file{$_}} > 1 }
+ keys %wildcards_same_section_by_file;
+
+ for my $file (@overmatched_same_section) {
+
+ my $patterns
+ = join($SPACE, sort @{$wildcards_same_section_by_file{$file}});
+
+ $self->pointed_hint('redundant-globbing-patterns',
+ $wildcard_pointer,"($patterns) for $file");
+ }
+
+ push(@redundant_wildcards,
+ map { @{$wildcards_same_section_by_file{$_}} }
+ @overmatched_same_section);
+
+ } continue {
+ $section_count++;
+ }
+
+ my @debian_years = keys %positions_by_debian_year;
+ my @changelog_entries = @{$self->processable->changelog->entries};
+
+ if (@debian_years && @changelog_entries) {
+
+ my @descending = reverse sort { $a <=> $b } @debian_years;
+ my $most_recent_copyright = $descending[0];
+
+ my $tp = Time::Piece->strptime($changelog_entries[0]->Date,
+ '%a, %d %b %Y %T %z');
+ my $most_recent_changelog = $tp->year;
+
+ my @candidates = @{$positions_by_debian_year{$most_recent_copyright}};
+ my @sorted = sort { $a <=> $b } @candidates;
+
+ # pick the topmost, which should be the broadest pattern
+ my $position = $candidates[0];
+
+ $self->pointed_hint('update-debian-copyright',
+ $copyright_file->pointer($position),
+ $most_recent_copyright, 'vs', $most_recent_changelog)
+ if $most_recent_copyright < $most_recent_changelog;
+ }
+
+ if ($check_wildcards) {
+
+ my @duplicate_wildcards= grep { @{$sections_by_wildcard{$_}} > 1 }
+ keys %sections_by_wildcard;
+
+ for my $wildcard (@duplicate_wildcards) {
+
+ my $lines = join($SPACE,
+ map { $_->position('Files') }
+ @{$sections_by_wildcard{$wildcard}});
+
+ $self->pointed_hint('duplicate-globbing-patterns',
+ $copyright_file->pointer,$wildcard, "(lines $lines)");
+ }
+
+ # do not issue next tag for duplicates or redundant wildcards
+ my $wildcard_lc = List::Compare->new(
+ [keys %sections_by_wildcard],
+ [
+ (
+ values %wildcard_by_file, @duplicate_wildcards,
+ @redundant_wildcards
+ )
+ ]
+ );
+ my @matches_nothing = $wildcard_lc->get_Lonly;
+
+ for my $wildcard (@matches_nothing) {
+ for my $section (@{$sections_by_wildcard{$wildcard}}) {
+
+ my $position = $section->position('Files');
+ my $pointer = $copyright_file->pointer($position);
+
+ $self->pointed_hint('superfluous-file-pattern', $pointer,
+ $wildcard);
+ }
+ }
+
+ my %sections_by_file;
+ for my $name (keys %wildcard_by_file) {
+
+ $sections_by_file{$name} //= [];
+ my $wildcard = $wildcard_by_file{$name};
+
+ push(
+ @{$sections_by_file{$name}},
+ @{$sections_by_wildcard{$wildcard}}
+ );
+ }
+
+ my %license_identifiers_by_file;
+ for my $name (keys %sections_by_file) {
+
+ $license_identifiers_by_file{$name} //= [];
+
+ push(
+ @{$license_identifiers_by_file{$name}},
+ $license_identifier_by_section{$_->position}
+ ) for @{$sections_by_file{$name}};
+ }
+
+ my @xml_searchspace = keys %license_identifiers_by_file;
+
+ # do not examine Lintian's test suite for appstream metadata
+ @xml_searchspace = grep { !m{t/} } @xml_searchspace
+ if $self->processable->name eq 'lintian';
+
+ for my $name (@xml_searchspace) {
+
+ next
+ if $name =~ '^\.pc/';
+
+ next
+ unless $name =~ /\.xml$/;
+
+ my $parser = XML::LibXML->new;
+ $parser->set_option('no_network', 1);
+
+ my $file = $self->processable->patched->resolve_path($name);
+ my $doc;
+ try {
+ $doc = $parser->parse_file($file->unpacked_path);
+
+ } catch {
+ next;
+ }
+
+ next
+ unless $doc;
+
+ my @nodes = $doc->findnodes('/component/metadata_license');
+ next
+ unless @nodes;
+
+ # take first one
+ my $first = $nodes[0];
+ next
+ unless $first;
+
+ my $seen = lc($first->firstChild->data // $EMPTY);
+ next
+ unless $seen;
+
+ # Compare and also normalize the seen and wanted license
+ # identifier wrt. to redundant trailing dot-zeros,
+ # -or-later suffix vs + suffix, -only suffix vs no
+ # suffix. Still display the original variant in the tag.
+ my $seen_normalized = $seen;
+ $seen_normalized = 'expat' if $seen_normalized eq 'mit';
+ $seen_normalized =~ s/-or-later$/+/i;
+ $seen_normalized =~ s/-only$//i;
+ my $seen_nozero = $seen_normalized;
+ $seen_nozero =~ s/\.0//g;
+
+ my @wanted = @{$license_identifiers_by_file{$name}};
+ my @mismatched = grep {
+ my $want = $_;
+ my $want_normalized = $want;
+ $want_normalized = 'expat' if $want_normalized eq 'mit';
+ $want_normalized =~ s/-or-later$/+/i;
+ $want_normalized =~ s/-only$//i;
+ my $want_nozero = $want_normalized;
+ $want_nozero =~ s/\.0//g;
+
+ $want_normalized ne $seen_normalized
+ and $want_nozero ne $seen_normalized
+ and $want_normalized ne $seen_nozero
+ and $want_nozero ne $seen_nozero;
+ } @wanted;
+
+ $self->pointed_hint('inconsistent-appstream-metadata-license',
+ $copyright_file->pointer, $name, "($seen != $_)")
+ for @mismatched;
+ }
+
+ my @no_license_needed = (@quilt_names, @notice_names);
+ my $unlicensed_lc
+ = List::Compare->new(\@shipped_names, \@no_license_needed);
+ my @license_needed = $unlicensed_lc->get_Lonly;
+
+ my @not_covered
+ = grep { !@{$sections_by_file{$_} // []} } @license_needed;
+
+ $self->pointed_hint('file-without-copyright-information',
+ $copyright_file->pointer, $_)
+ for @not_covered;
+ }
+
+ my $standalone_lc= List::Compare->new([keys %required_standalone],
+ [keys %found_standalone]);
+ my @missing_standalone = $standalone_lc->get_Lonly;
+ my @matched_standalone = $standalone_lc->get_intersection;
+ my @unused_standalone = $standalone_lc->get_Ronly;
+
+ for my $license (@missing_standalone) {
+
+ my $section = $required_standalone{$license};
+
+ my $position = $section->position('License');
+ my $pointer = $copyright_file->pointer($position);
+
+ $self->pointed_hint('missing-license-paragraph-in-dep5-copyright',
+ $pointer, $license);
+ }
+
+ for my $license (grep { $_ ne 'public-domain' } @unused_standalone) {
+
+ for my $section (@{$found_standalone{$license}}) {
+
+ my $position = $section->position('License');
+ my $pointer = $copyright_file->pointer($position);
+
+ $self->pointed_hint('unused-license-paragraph-in-dep5-copyright',
+ $pointer, $license);
+ }
+ }
+
+ for my $license (@matched_standalone) {
+
+ my $section = $required_standalone{$license};
+
+ my $position = $section->position('Files');
+ my $pointer = $copyright_file->pointer($position);
+
+ $self->pointed_hint('dep5-file-paragraph-references-header-paragraph',
+ $pointer, $license)
+ if all { $_ == $header } @{$found_standalone{$license}};
+ }
+
+ # license files do not require their own entries in d/copyright.
+ my $license_lc
+ = List::Compare->new(\@notice_names, [keys %sections_by_wildcard]);
+ my @listed_licenses = $license_lc->get_intersection;
+
+ $self->pointed_hint('license-file-listed-in-debian-copyright',
+ $copyright_file->pointer, $_)
+ for @listed_licenses;
+
+ return;
+}
+
+sub escape_errors {
+ my ($escaped) = @_;
+
+ my @sequences = ($escaped =~ m{\\.?}g);
+ my @illegal = grep { !m{^\\[*?]$} } @sequences;
+
+ return @illegal;
+}
+
+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/Lintian/Check/Debian/Copyright/Dep5/Components.pm b/lib/Lintian/Check/Debian/Copyright/Dep5/Components.pm
new file mode 100644
index 0000000..453a40b
--- /dev/null
+++ b/lib/Lintian/Check/Debian/Copyright/Dep5/Components.pm
@@ -0,0 +1,109 @@
+# debian/copyright/dep5/components -- lintian check script -*- perl -*-
+
+# Copyright (C) 2021 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 Lintian::Check::Debian::Copyright::Dep5::Components;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use List::Compare;
+use Syntax::Keyword::Try;
+
+use Lintian::Deb822;
+
+use Moo;
+use namespace::clean;
+
+with 'Lintian::Check';
+
+sub source {
+ my ($self) = @_;
+
+ my $debian_dir = $self->processable->patched->resolve_path('debian/');
+ return
+ unless defined $debian_dir;
+
+ my @installables = $self->processable->debian_control->installables;
+ my @additional = map { $_ . '.copyright' } @installables;
+
+ my @candidates = ('copyright', @additional);
+ my @files = grep { defined $_ && !$_->is_symlink }
+ map { $debian_dir->child($_) } @candidates;
+
+ # another check complains about legacy encoding, if needed
+ my @valid_utf8 = grep { $_->is_valid_utf8 } @files;
+
+ $self->check_dep5_copyright($_) for @valid_utf8;
+
+ return;
+}
+
+sub check_dep5_copyright {
+ my ($self, $copyright_file) = @_;
+
+ my $deb822 = Lintian::Deb822->new;
+
+ my @sections;
+ try {
+ @sections = $deb822->read_file($copyright_file->unpacked_path);
+
+ } catch {
+ # may not be in DEP 5 format
+ return;
+ }
+
+ return
+ unless @sections;
+
+ my ($header, @followers) = @sections;
+
+ my @initial_path_components;
+
+ for my $section (@followers) {
+
+ my @subdirs = $section->trimmed_list('Files');
+ s{ / .* $}{}x for @subdirs;
+
+ my @definite = grep { !/[*?]/ } @subdirs;
+
+ push(@initial_path_components, grep { length } @definite);
+ }
+
+ my @extra_source_components
+ = grep { length } values %{$self->processable->components};
+ my $component_lc = List::Compare->new(\@extra_source_components,
+ \@initial_path_components);
+
+ my @missing_components = $component_lc->get_Lonly;
+
+ $self->pointed_hint('add-component-copyright', $copyright_file->pointer,$_)
+ for @missing_components;
+
+ return;
+}
+
+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/Lintian/Check/Debian/Debconf.pm b/lib/Lintian/Check/Debian/Debconf.pm
new file mode 100644
index 0000000..6b86bf9
--- /dev/null
+++ b/lib/Lintian/Check/Debian/Debconf.pm
@@ -0,0 +1,794 @@
+# debian/debconf -- lintian check script -*- perl -*-
+
+# Copyright (C) 2001 Colin Watson
+# Copyright (C) 2020-21 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 Lintian::Check::Debian::Debconf;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Const::Fast;
+use List::SomeUtils qw(none);
+use Path::Tiny;
+use Syntax::Keyword::Try;
+use Unicode::UTF8 qw(encode_utf8);
+
+use Lintian::Deb822;
+use Lintian::Deb822::Constants qw(DCTRL_DEBCONF_TEMPLATE);
+use Lintian::Relation;
+use Lintian::Util qw($PKGNAME_REGEX);
+
+use Moo;
+use namespace::clean;
+
+with 'Lintian::Check';
+
+const my $EMPTY => q{};
+const my $SPACE => q{ };
+
+const my $MAXIMUM_TEMPLATE_SYNOPSIS => 75;
+const my $MAXIMUM_LINE_LENGTH => 80;
+const my $MAXIMUM_LINES => 20;
+const my $ITEM_NOT_FOUND => -1;
+
+# From debconf-devel(7), section 'THE TEMPLATES FILE', up to date with debconf
+# version 1.5.24. Added indices for cdebconf (indicates sort order for
+# choices); debconf doesn't support it, but it ignores it, which is safe
+# behavior. Likewise, help is supported as of cdebconf 0.143 but is not yet
+# supported by debconf.
+my %template_fields
+ = map { $_ => 1 } qw(Template Type Choices Indices Default Description Help);
+
+# From debconf-devel(7), section 'THE TEMPLATES FILE', up to date with debconf
+# version 1.5.24.
+my %valid_types = map { $_ => 1 } qw(
+ string
+ password
+ boolean
+ select
+ multiselect
+ note
+ error
+ title
+ text);
+
+# From debconf-devel(7), section 'THE DEBCONF PROTOCOL' under 'INPUT', up to
+# date with debconf version 1.5.24.
+my %valid_priorities = map { $_ => 1 } qw(low medium high critical);
+
+# All the packages that provide debconf functionality. Anything using debconf
+# needs to have dependencies that satisfy one of these.
+my $ANY_DEBCONF = Lintian::Relation->new->load(
+ join(
+ ' | ', qw(debconf debconf-2.0 cdebconf
+ cdebconf-udeb libdebconfclient0 libdebconfclient0-udeb)
+ )
+);
+
+sub source {
+ my ($self) = @_;
+
+ my @catalogs= (
+ 'templates',
+ map { "$_.templates" }$self->processable->debian_control->installables
+ );
+ my @files = grep { defined }
+ map { $self->processable->patched->resolve_path("debian/$_") } @catalogs;
+
+ my @utf8 = grep { $_->is_valid_utf8 and $_->is_file } @files;
+ for my $item (@utf8) {
+
+ my $deb822 = Lintian::Deb822->new;
+
+ my @templates;
+ try {
+ @templates
+ = $deb822->read_file($item->unpacked_path,
+ DCTRL_DEBCONF_TEMPLATE);
+
+ } catch {
+ my $error = $@;
+ chomp $error;
+ $error =~ s{^syntax error in }{};
+
+ $self->pointed_hint('syntax-error-in-debconf-template',
+ $item->pointer, $error);
+
+ next;
+ }
+
+ my @unsplit_choices
+ = grep {$_->declares('Template') && $_->declares('_Choices')}
+ @templates;
+
+ $self->pointed_hint(
+ 'template-uses-unsplit-choices',
+ $item->pointer($_->position('_Choices')),
+ $_->value('Template')
+ )for @unsplit_choices;
+ }
+
+ return;
+}
+
+sub installable {
+ my ($self) = @_;
+
+ my $usespreinst;
+ my $preinst = $self->processable->control->lookup('preinst');
+
+ if ($preinst and $preinst->is_file and $preinst->is_open_ok) {
+
+ open(my $fd, '<', $preinst->unpacked_path)
+ or die encode_utf8('Cannot open ' . $preinst->unpacked_path);
+
+ while (my $line = <$fd>) {
+ $line =~ s/\#.*//; # Not perfect for Perl, but should be OK
+
+ if ( $line =~ m{/usr/share/debconf/confmodule}
+ || $line =~ /(?:Debconf|Debian::DebConf)::Client::ConfModule/){
+ $usespreinst=1;
+
+ last;
+ }
+ }
+ close($fd);
+ }
+
+ my $seenconfig;
+ my $ctrl_config = $self->processable->control->lookup('config');
+ if (defined $ctrl_config && $ctrl_config->is_file) {
+
+ $self->pointed_hint('debconf-config-not-executable',
+ $ctrl_config->pointer)
+ unless $ctrl_config->is_executable;
+
+ $seenconfig = 1;
+ }
+
+ my $seentemplates;
+ my $ctrl_templates = $self->processable->control->lookup('templates');
+ $seentemplates = 1 if $ctrl_templates and $ctrl_templates->is_file;
+
+ # This still misses packages that use debconf only in the postrm.
+ # Packages that ask debconf questions in the postrm should load
+ # the confmodule in the postinst so that debconf can register
+ # their templates.
+ return
+ unless $seenconfig
+ or $seentemplates
+ or $usespreinst;
+
+ # parse depends info for later checks
+
+ # Consider every package to depend on itself.
+ my $selfrel;
+ if ($self->processable->fields->declares('Version')) {
+ my $version = $self->processable->fields->value('Version');
+ $selfrel = $self->processable->name . " (= $version)";
+ } else {
+ $selfrel = $self->processable->name;
+ }
+
+ # Include self and provides as a package providing debconf presumably
+ # satisfies its own use of debconf (if any).
+ my $selfrelation
+ = $self->processable->relation('Provides')->logical_and($selfrel);
+ my $alldependencies
+ = $self->processable->relation('strong')->logical_and($selfrelation);
+
+ # See if the package depends on dbconfig-common. Packages that do
+ # are allowed to have a config file with no templates, since they
+ # use the dbconfig-common templates.
+ my $usesdbconfig = $alldependencies->satisfies('dbconfig-common');
+
+ # Check that both debconf control area files are present.
+ if ($seenconfig and not $seentemplates and not $usesdbconfig) {
+
+ $self->hint('no-debconf-templates');
+
+ } elsif ($seentemplates
+ and not $seenconfig
+ and not $usespreinst
+ and $self->processable->type ne 'udeb') {
+
+ $self->hint('no-debconf-config');
+ }
+
+ # Lots of template checks.
+
+ my @templates;
+ if ($seentemplates) {
+
+ if ($ctrl_templates->is_valid_utf8) {
+ my $deb822 = Lintian::Deb822->new;
+
+ try {
+ # $seentemplates (above) will be false if $ctrl_templates is a
+ # symlink or not a file, so this should be safe without
+ # (re-checking) with -f/-l.
+ @templates= $deb822->read_file($ctrl_templates->unpacked_path,
+ DCTRL_DEBCONF_TEMPLATE);
+
+ } catch {
+ my $error = $@;
+ chomp $error;
+ $error =~ s{^syntax error in }{};
+
+ $self->pointed_hint('syntax-error-in-debconf-template',
+ $ctrl_templates->pointer, $error);
+
+ @templates = ();
+ }
+ }
+ }
+
+ my %template_by_name;
+ my %potential_db_abuse;
+ for my $template (@templates) {
+
+ my $isselect = $EMPTY;
+ my $name = $template->value('Template');
+
+ if (!$template->declares('Template')) {
+ $self->pointed_hint('no-template-name',
+ $ctrl_templates->pointer($template->position));
+ $name = 'no-template-name';
+
+ } else {
+ $template_by_name{$name} = $template;
+
+ $self->pointed_hint('malformed-template-name',
+ $ctrl_templates->pointer($template->position('Template')),
+ $name)
+ unless $name =~ m{[A-Za-z0-9.+-](?:/[A-Za-z0-9.+-])};
+ }
+
+ my $type = $template->value('Type');
+ if (!$template->declares('Type')) {
+
+ $self->pointed_hint('no-template-type',
+ $ctrl_templates->pointer($template->position), $name);
+
+ } elsif (!$valid_types{$type}) {
+
+ # cdebconf has a special "entropy" type
+ $self->pointed_hint('unknown-template-type',
+ $ctrl_templates->pointer($template->position('Type')), $type)
+ unless $type eq 'entropy'
+ && $alldependencies->satisfies('cdebconf');
+
+ } elsif ($type eq 'select' || $type eq 'multiselect') {
+ $isselect = 1;
+
+ } elsif ($type eq 'boolean') {
+
+ my $default = $template->value('Default');
+
+ $self->pointed_hint(
+ 'boolean-template-has-bogus-default',
+ $ctrl_templates->pointer($template->position('Default')),
+ $name, $default
+ )
+ if $template->declares('Default')
+ && (none { $default eq $_ } qw(true false));
+ }
+
+ my $choices = $template->value('Choices');
+ if ($template->declares('Choices') && $choices !~ /^\s*$/) {
+
+ my $nrchoices = count_choices($choices);
+ for my $key ($template->names) {
+
+ if ($key =~ /^Choices-/) {
+ my $translated = $template->value($key);
+
+ if (!length($translated) || $translated =~ /^\s*$/){
+ $self->pointed_hint(
+ 'empty-translated-choices',
+ $ctrl_templates->pointer(
+ $template->position('Choices')
+ ),
+ $name, $key
+ );
+ }
+
+ if (count_choices($translated) != $nrchoices) {
+ $self->pointed_hint(
+ 'mismatch-translated-choices',
+ $ctrl_templates->pointer(
+ $template->position('Choices')
+ ),
+ $name,$key
+ );
+ }
+ }
+ }
+
+ $self->pointed_hint('select-with-boolean-choices',
+ $ctrl_templates->pointer($template->position('Choices')),$name)
+ if $choices =~ /^\s*(yes\s*,\s*no|no\s*,\s*yes)\s*$/i;
+ }
+
+ $self->pointed_hint('select-without-choices',
+ $ctrl_templates->pointer($template->position), $name)
+ if $isselect && !$template->declares('Choices');
+
+ my $description = $template->value('Description');
+
+ $self->pointed_hint('no-template-description',
+ $ctrl_templates->pointer($template->position), $name)
+ unless length $description
+ || length $template->value('_Description');
+
+ if ($description =~ /^\s*(.*?)\s*?\n\s*\1\s*$/){
+
+ # Check for duplication. Should all this be folded into the
+ # description checks?
+ $self->pointed_hint('duplicate-long-description-in-template',
+ $ctrl_templates->pointer($template->position('Description')),
+ $name);
+ }
+
+ my %languages;
+ for my $field ($template->names) {
+ # Tests on translations
+ my ($mainfield, $lang) = split m/-/, $field, 2;
+ if (defined $lang) {
+ $languages{$lang}{$mainfield}=1;
+ }
+ my $stripped = $mainfield;
+ $stripped =~ s/^_//;
+ unless ($template_fields{$stripped}) {
+ # Ignore language codes here
+ $self->pointed_hint('unknown-field-in-templates',
+ $ctrl_templates->pointer($template->position($field)),
+ $name, $field);
+ }
+ }
+
+ if (length $name && length $type) {
+ $potential_db_abuse{$name} = 1
+ if $type eq 'note' || $type eq 'text';
+ }
+
+ # Check the description against the best practices in the
+ # Developer's Reference, but skip all templates where the
+ # short description contains the string "for internal use".
+ my ($short, $extended);
+ if (length $description) {
+ ($short, $extended) = split(/\n/, $description, 2);
+ unless (defined $short) {
+ $short = $description;
+ $extended = $EMPTY;
+ }
+ } else {
+ $short = $EMPTY;
+ $extended = $EMPTY;
+ }
+
+ my $ttype = $type;
+ unless ($short =~ /for internal use/i) {
+
+ my $pointer
+ = $ctrl_templates->pointer($template->position('Description'));
+
+ my $isprompt = grep { $_ eq $ttype } qw(string password);
+ if ($isprompt) {
+ if (
+ $short
+ && ( $short !~ m/:$/
+ || $short =~ m/^(what|who|when|where|which|how)/i)
+ ) {
+ $self->pointed_hint('malformed-prompt-in-templates',
+ $pointer, $name);
+ }
+ }
+ if ($isselect) {
+ if ($short =~ /^(Please|Cho+se|Enter|Select|Specify|Give)/) {
+ $self->pointed_hint('using-imperative-form-in-templates',
+ $pointer, $name);
+ }
+ }
+ if ($ttype eq 'boolean') {
+ if ($short !~ /\?/) {
+ $self->pointed_hint('malformed-question-in-templates',
+ $pointer, $name);
+ }
+ }
+ if (defined $extended && $extended =~ /[^\?]\?(\s+|$)/) {
+ $self->pointed_hint(
+ 'using-question-in-extended-description-in-templates',
+ $pointer, $name);
+ }
+ if ($ttype eq 'note') {
+ if ($short =~ /[.?;:]$/) {
+ $self->pointed_hint('malformed-title-in-templates',
+ $pointer, $name);
+ }
+ }
+ if (length $short > $MAXIMUM_TEMPLATE_SYNOPSIS) {
+ $self->pointed_hint('too-long-short-description-in-templates',
+ $pointer, $name)
+ unless $self->processable->type eq 'udeb'
+ && $ttype eq 'text';
+ }
+ if (defined $description) {
+ if ($description
+ =~ /(\A|\s)(I|[Mm]y|[Ww]e|[Oo]ur|[Oo]urs|mine|myself|ourself|me|us)(\Z|\s)/
+ ) {
+ $self->pointed_hint('using-first-person-in-templates',
+ $pointer,$name);
+ }
+ if ( $description =~ /[ \'\"]yes[ \'\",;.]/i
+ and $ttype eq 'boolean') {
+
+ $self->pointed_hint(
+ 'making-assumptions-about-interfaces-in-templates',
+ $pointer, $name);
+ }
+ }
+
+ # Check whether the extended description is too long.
+ if ($extended) {
+
+ my $lines = 0;
+ for my $string (split(/\n/, $extended)) {
+
+ while (length $string > $MAXIMUM_LINE_LENGTH) {
+
+ my $index
+ = rindex($string, $SPACE, $MAXIMUM_LINE_LENGTH);
+
+ if ($index == $ITEM_NOT_FOUND) {
+ $index = index($string, $SPACE);
+ }
+
+ if ($index == $ITEM_NOT_FOUND) {
+ $string = $EMPTY;
+
+ } else {
+ $string = substr($string, $index + 1);
+ $lines++;
+ }
+ }
+
+ $lines++;
+ }
+
+ if ($lines > $MAXIMUM_LINES) {
+ $self->pointed_hint(
+ 'too-long-extended-description-in-templates',
+ $pointer, $name);
+ }
+ }
+ }
+ }
+
+ # Check the maintainer scripts.
+
+ my ($config_calls_db_input, $db_purge);
+ my (%templates_used, %template_aliases);
+ for my $file (qw(config prerm postrm preinst postinst)) {
+
+ my $potential_makedev = {};
+
+ my $item = $self->processable->control->lookup($file);
+
+ if (defined $item && $item->is_file && $item->is_open_ok) {
+
+ my ($usesconfmodule, $obsoleteconfmodule, $db_input, $isdefault);
+
+ open(my $fd, '<', $item->unpacked_path)
+ or die encode_utf8('Cannot open ' . $item->unpacked_path);
+
+ # Only check scripts.
+ my $fl = <$fd>;
+ unless ($fl && $fl =~ /^\#!/) {
+ close($fd);
+ next;
+ }
+
+ my $position = 1;
+ while (my $line = <$fd>) {
+
+ # not perfect for Perl, but should be OK
+ $line =~ s/#.*//;
+
+ next
+ unless $line =~ /\S/;
+
+ while ($line =~ s{\\$}{}) {
+ my $next = <$fd>;
+ ++$position;
+
+ last
+ unless $next;
+
+ $line .= $next;
+ }
+
+ if ($line =~ m{(?:\.|source)\s+/usr/share/debconf/confmodule}
+ || $line=~ /(?:use|require)\s+Debconf::Client::ConfModule/)
+ {
+ $usesconfmodule=1;
+ }
+
+ my $pointer = $item->pointer($position);
+
+ if (
+ !$obsoleteconfmodule
+ && $line =~ m{(/usr/share/debconf/confmodule\.sh|
+ Debian::DebConf::Client::ConfModule)}x
+ ) {
+ my $module = $1;
+
+ $self->pointed_hint('loads-obsolete-confmodule', $pointer,
+ $module);
+
+ $usesconfmodule = 1;
+ $obsoleteconfmodule = 1;
+ }
+
+ if ($item->name eq 'config' && $line =~ /db_input/) {
+ $config_calls_db_input = 1;
+ }
+
+ if ( $item->name eq 'postinst'
+ && !$db_input
+ && $line =~ /db_input/
+ && !$config_calls_db_input) {
+
+ # TODO: Perl?
+ $self->pointed_hint('postinst-uses-db-input', $pointer)
+ unless $self->processable->type eq 'udeb';
+ $db_input=1;
+ }
+
+ if ($line =~ m{/dev/}) {
+ $potential_makedev->{$position} = 1;
+ }
+
+ if (
+ $line =~m{\A \s*(?:db_input|db_text)\s+
+ [\"\']? (\S+?) [\"\']? \s+ (\S+)\s}xsm
+ ) {
+ my $priority = $1;
+ my $unmangled = $2;
+
+ $templates_used{$self->get_template_name($unmangled)}= 1;
+
+ if ($priority !~ /^\$\S+$/) {
+
+ $self->pointed_hint('unknown-debconf-priority',
+ $pointer, $priority)
+ unless ($valid_priorities{$priority});
+
+ $self->pointed_hint('possible-debconf-note-abuse',
+ $pointer, $unmangled)
+ if (
+ $potential_db_abuse{$unmangled}
+ and (
+ not($potential_makedev->{($position - 1)}
+ and ($priority eq 'low'))
+ )
+ and ($priority eq 'low' || $priority eq 'medium')
+ );
+ }
+ }
+
+ if (
+ $line =~m{ \A \s* (?:db_get|db_set(?:title)?) \s+
+ [\"\']? (\S+?) [\"\']? (?:\s|\Z)}xsm
+ ) {
+ $templates_used{$self->get_template_name($1)} = 1;
+ }
+
+ # Try to handle Perl somewhat.
+ if ($line =~ /^\s*(?:.*=\s*get|set)\s*\(\s*[\"\'](\S+?)[\"\']/
+ || $line
+ =~ /\b(?:metaget|settitle)\s*\(\s*[\"\'](\S+?)[\"\']/) {
+ $templates_used{$1} = 1;
+ }
+
+ if ($line=~ /^\s*db_register\s+[\"\']?(\S+?)[\"\']?\s+(\S+)\s/)
+ {
+ my ($template, $question) = ($1, $2);
+ push @{$template_aliases{$template}}, $question;
+ }
+ if (!$isdefault && $line =~ /db_fset.*isdefault/) {
+ # TODO: Perl?
+ $self->pointed_hint('isdefault-flag-is-deprecated',
+ $pointer);
+ $isdefault = 1;
+ }
+
+ if (!$db_purge && $line =~ /db_purge/) { # TODO: Perl?
+ $db_purge = 1;
+ }
+
+ } continue {
+ ++$position;
+ }
+
+ close $fd;
+
+ if ($self->processable->type ne 'udeb') {
+ if ($item->name eq 'config'
+ || ($seenconfig && $item->name eq 'postinst')){
+
+ $self->pointed_hint("$file-does-not-load-confmodule",
+ $item->pointer)
+ unless $usesconfmodule;
+ }
+ }
+
+ if ($item->name eq 'postrm') {
+ # If we haven't seen db_purge we emit the tag unless the
+ # package is a debconf provider (in which case db_purge
+ # won't be available)
+ unless ($db_purge or $selfrelation->satisfies($ANY_DEBCONF)) {
+
+ $self->pointed_hint('postrm-does-not-purge-debconf',
+ $item->pointer);
+ }
+ }
+
+ } elsif ($file eq 'postinst') {
+
+ $self->hint('postinst-does-not-load-confmodule', $file)
+ if $self->processable->type ne 'udeb' && $seenconfig;
+
+ } elsif ($file eq 'postrm') {
+ # Make an exception for debconf providing packages as some of
+ # them (incl. "debconf" itself) cleans up in prerm and have no
+ # postrm script at all.
+ $self->hint('postrm-does-not-purge-debconf', $file)
+ unless $self->processable->type eq 'udeb'
+ or $selfrelation->satisfies($ANY_DEBCONF);
+ }
+ }
+
+ for my $name (keys %template_by_name) {
+
+ $name =~ s/\s+\Z//;
+
+ my $used = 0;
+
+ if ($templates_used{$name}) {
+ $used = 1;
+ } else {
+ foreach my $alias (@{$template_aliases{$name}}) {
+ if ($templates_used{$alias}) {
+ $used = 1;
+ last;
+ }
+ }
+ }
+
+ my $template = $template_by_name{$name};
+ my $position = $template->position('Template');
+ my $pointer = $ctrl_templates->pointer($position);
+
+ $self->pointed_hint('unused-debconf-template', $pointer, $name)
+ unless $name =~ m{^shared/packages-(wordlist|ispell)$}
+ || $name =~ m{/languages$}
+ || $used
+ || $self->processable->name eq 'debconf'
+ || $self->processable->type eq 'udeb';
+ }
+
+ # Check that the right dependencies are in the control file. Accept any
+ # package that might provide debconf functionality.
+
+ if ($usespreinst) {
+ unless ($self->processable->relation('Pre-Depends')
+ ->satisfies($ANY_DEBCONF)){
+ $self->hint('missing-debconf-dependency-for-preinst')
+ unless $self->processable->type eq 'udeb';
+ }
+ } else {
+ unless ($alldependencies->satisfies($ANY_DEBCONF) or $usesdbconfig) {
+ $self->hint('missing-debconf-dependency');
+ }
+ }
+
+ # Now make sure that no scripts are using debconf as a registry.
+ # Unfortunately this requires us to unpack to level 2 and grep all the
+ # scripts in the package.
+ # the following checks is ignored if the package being checked is debconf
+ # itself.
+
+ return
+ if ($self->processable->name eq 'debconf')
+ || ($self->processable->type eq 'udeb');
+
+ my @scripts
+ = grep { $_->is_script } @{$self->processable->installed->sorted_list};
+ for my $item (@scripts) {
+
+ next
+ unless $item->is_open_ok;
+
+ open(my $fd, '<', $item->unpacked_path)
+ or die encode_utf8('Cannot open ' . $item->unpacked_path);
+
+ my $position = 1;
+ while (my $line = <$fd>) {
+
+ # Not perfect for Perl, but should be OK
+ $line =~ s/#.*//;
+
+ if ( $line =~ m{/usr/share/debconf/confmodule}
+ || $line =~ /(?:Debconf|Debian::DebConf)::Client::ConfModule/){
+
+ $self->pointed_hint('debconf-is-not-a-registry',
+ $item->pointer($position));
+ last;
+ }
+
+ } continue {
+ ++$position;
+ }
+
+ close $fd;
+ }
+
+ return;
+} # </run>
+
+# -----------------------------------
+
+# Count the number of choices. Splitting code copied from debconf 1.5.8
+# (Debconf::Question).
+sub count_choices {
+ my ($choices) = @_;
+ my @items;
+ my $item = $EMPTY;
+ for my $chunk (split /(\\[, ]|,\s+)/, $choices) {
+ if ($chunk =~ /^\\([, ])$/) {
+ $item .= $1;
+ } elsif ($chunk =~ /^,\s+$/) {
+ push(@items, $item);
+ $item = $EMPTY;
+ } else {
+ $item .= $chunk;
+ }
+ }
+ push(@items, $item) if $item ne $EMPTY;
+ return scalar(@items);
+}
+
+# Manually interpolate shell variables, eg. $DPKG_MAINTSCRIPT_PACKAGE
+sub get_template_name {
+ my ($self, $name) = @_;
+
+ my $package = $self->processable->name;
+ return $name =~ s/^\$DPKG_MAINTSCRIPT_PACKAGE/$package/r;
+}
+
+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/Lintian/Check/Debian/DesktopEntries.pm b/lib/Lintian/Check/Debian/DesktopEntries.pm
new file mode 100644
index 0000000..cff6042
--- /dev/null
+++ b/lib/Lintian/Check/Debian/DesktopEntries.pm
@@ -0,0 +1,58 @@
+# debian/desktop-entries -- lintian check script -*- perl -*-
+
+# 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 Lintian::Check::Debian::DesktopEntries;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Moo;
+use namespace::clean;
+
+with 'Lintian::Check';
+
+sub source {
+ my ($self) = @_;
+
+ return
+ if $self->processable->native;
+
+ my $debiandir = $self->processable->patched->resolve_path('debian');
+ return
+ unless $debiandir;
+
+ my @files = grep { $_->is_file } $debiandir->descendants;
+ my @nopatches = grep { $_->name !~ m{^debian/patches/} } @files;
+
+ my @manpages = grep { $_->basename =~ m{\.desktop$} } @nopatches;
+
+ $self->pointed_hint('maintainer-desktop-entry', $_->pointer) for @manpages;
+
+ return;
+}
+
+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/Lintian/Check/Debian/Filenames.pm b/lib/Lintian/Check/Debian/Filenames.pm
new file mode 100644
index 0000000..c18b129
--- /dev/null
+++ b/lib/Lintian/Check/Debian/Filenames.pm
@@ -0,0 +1,78 @@
+# debian/filenames -- lintian check script -*- perl -*-
+
+# 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 Lintian::Check::Debian::Filenames;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Moo;
+use namespace::clean;
+
+with 'Lintian::Check';
+
+sub source {
+ my ($self) = @_;
+
+ # names are different in installation packages (see #429510)
+ # README and TODO may be handled differently
+
+ my @often_misnamed = (
+ { correct => 'NEWS', problematic => 'NEWS.Debian' },
+ { correct => 'NEWS', problematic => 'NEWS.debian' },
+ { correct => 'TODO', problematic => 'TODO.Debian' },
+ { correct => 'TODO', problematic => 'TODO.debian' }
+ );
+
+ for my $relative (@often_misnamed) {
+
+ my $problematic_item = $self->processable->patched->resolve_path(
+ 'debian/' . $relative->{problematic});
+
+ next
+ unless defined $problematic_item;
+
+ my $correct_name = 'debian/' . $relative->{correct};
+ if ($self->processable->patched->resolve_path($correct_name)) {
+
+ $self->pointed_hint('duplicate-packaging-file',
+ $problematic_item->pointer,
+ 'better:', $correct_name);
+
+ } else {
+ $self->pointed_hint(
+ 'incorrect-packaging-filename',
+ $problematic_item->pointer,
+ 'better:', $correct_name
+ );
+ }
+ }
+
+ return;
+}
+
+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/Lintian/Check/Debian/Files.pm b/lib/Lintian/Check/Debian/Files.pm
new file mode 100644
index 0000000..921f48b
--- /dev/null
+++ b/lib/Lintian/Check/Debian/Files.pm
@@ -0,0 +1,60 @@
+# debian/files -- lintian check script -*- perl -*-
+#
+# based on debhelper check,
+# Copyright (C) 1999 Joey Hess
+# Copyright (C) 2000 Sean 'Shaleh' Perry
+# Copyright (C) 2002 Josip Rodin
+# Copyright (C) 2007 Russ Allbery
+# Copyright (C) 2013-2018 Bastien ROUCARIES
+# Copyright (C) 2017-2020 Chris Lamb <lamby@debian.org>
+# 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 Lintian::Check::Debian::Files;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Moo;
+use namespace::clean;
+
+with 'Lintian::Check';
+
+sub visit_patched_files {
+ my ($self, $item) = @_;
+
+ return
+ unless $item->is_file;
+
+ return
+ unless $item->name eq 'debian/files';
+
+ $self->pointed_hint('debian-files-list-in-source', $item->pointer)
+ if $item->size > 0;
+
+ return;
+}
+
+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/Lintian/Check/Debian/LineSeparators.pm b/lib/Lintian/Check/Debian/LineSeparators.pm
new file mode 100644
index 0000000..3c174ab
--- /dev/null
+++ b/lib/Lintian/Check/Debian/LineSeparators.pm
@@ -0,0 +1,62 @@
+# debian/line-separators -- lintian check script -*- perl -*-
+#
+# based on debhelper check,
+# Copyright (C) 1999 Joey Hess
+# Copyright (C) 2000 Sean 'Shaleh' Perry
+# Copyright (C) 2002 Josip Rodin
+# Copyright (C) 2007 Russ Allbery
+# Copyright (C) 2013-2018 Bastien ROUCARIES
+# Copyright (C) 2017-2020 Chris Lamb <lamby@debian.org>
+# 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 Lintian::Check::Debian::LineSeparators;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use List::SomeUtils qw(none);
+
+use Moo;
+use namespace::clean;
+
+with 'Lintian::Check';
+
+# files in ./debian to check for line terminators
+my @CANDIDATES = qw(debian/control debian/changelog);
+
+sub visit_patched_files {
+ my ($self, $item) = @_;
+
+ return
+ if none { $item->name eq $_ } @CANDIDATES;
+
+ $self->pointed_hint('carriage-return-line-feed', $item->pointer)
+ if $item->bytes =~ m{\r\n\Z}m;
+
+ return;
+}
+
+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/Lintian/Check/Debian/LintianOverrides.pm b/lib/Lintian/Check/Debian/LintianOverrides.pm
new file mode 100644
index 0000000..448e7f9
--- /dev/null
+++ b/lib/Lintian/Check/Debian/LintianOverrides.pm
@@ -0,0 +1,64 @@
+# debian/lintian-overrides -- lintian check script -*- perl -*-
+
+# Copyright (C) 1998 Christian Schwarz and Richard Braakman
+#
+# 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 Lintian::Check::Debian::LintianOverrides;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Moo;
+use namespace::clean;
+
+with 'Lintian::Check';
+
+sub visit_installed_files {
+ my ($self, $item) = @_;
+
+ my $ppkg = quotemeta($self->processable->name);
+
+ # misplaced overrides
+ if ($item->name =~ m{^usr/share/doc/$ppkg/override\.[lL]intian(?:\.gz)?$}
+ || $item->name =~ m{^usr/share/lintian/overrides/$ppkg/.+}) {
+
+ $self->pointed_hint('override-file-in-wrong-location', $item->pointer);
+
+ } elsif ($item->name =~ m{^usr/share/lintian/overrides/(.+)/.+$}) {
+
+ my $expected = $1;
+
+ $self->pointed_hint('override-file-in-wrong-package',
+ $item->pointer, $expected)
+ unless $self->processable->name eq $expected;
+ }
+
+ $self->pointed_hint('old-source-override-location', $item->pointer)
+ if $item->name eq 'debian/source.lintian-overrides';
+
+ return;
+}
+
+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/Lintian/Check/Debian/LintianOverrides/Comments.pm b/lib/Lintian/Check/Debian/LintianOverrides/Comments.pm
new file mode 100644
index 0000000..11c0077
--- /dev/null
+++ b/lib/Lintian/Check/Debian/LintianOverrides/Comments.pm
@@ -0,0 +1,88 @@
+# debian/lintian-overrides/comments -- lintian check script -*- perl -*-
+
+# Copyright (C) 2020-2021 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 Lintian::Check::Debian::LintianOverrides::Comments;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use POSIX qw(ENOENT);
+
+use Lintian::Spelling qw(check_spelling check_spelling_picky);
+
+use Moo;
+use namespace::clean;
+
+with 'Lintian::Check';
+
+sub always {
+ my ($self) = @_;
+
+ my @declared_overrides = @{$self->processable->overrides};
+
+ for my $override (@declared_overrides) {
+
+ next
+ unless length $override->justification;
+
+ my $tag_name = $override->tag_name;
+
+ # comments appear one or more lines before the override
+ # but they were concatenated
+ my $position = $override->position - 1;
+
+ my $pointer= $self->processable->override_file->pointer($position);
+
+ check_spelling(
+ $self->data,
+ $override->justification,
+ $self->group->spelling_exceptions,
+ $self->emitter('spelling-in-override-comment',$pointer, $tag_name)
+ );
+
+ check_spelling_picky(
+ $self->data,
+ $override->justification,
+ $self->emitter(
+ 'capitalization-in-override-comment',
+ $pointer,$tag_name
+ )
+ );
+ }
+
+ return;
+}
+
+sub emitter {
+ my ($self, @prefixed) = @_;
+
+ return sub {
+ return $self->pointed_hint(@prefixed, @_);
+ };
+}
+
+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/Lintian/Check/Debian/LintianOverrides/Duplicate.pm b/lib/Lintian/Check/Debian/LintianOverrides/Duplicate.pm
new file mode 100644
index 0000000..e52d140
--- /dev/null
+++ b/lib/Lintian/Check/Debian/LintianOverrides/Duplicate.pm
@@ -0,0 +1,75 @@
+# debian/lintian-overrides/duplicate -- lintian check script -*- perl -*-
+
+# Copyright (C) 2021 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 Lintian::Check::Debian::LintianOverrides::Duplicate;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Const::Fast;
+
+const my $SPACE => q{ };
+
+use Moo;
+use namespace::clean;
+
+with 'Lintian::Check';
+
+sub always {
+ my ($self) = @_;
+
+ my %pattern_tracker;
+ for my $override (@{$self->processable->overrides}) {
+
+ my $pattern = $override->pattern;
+
+ # catch renames
+ my $tag_name = $self->profile->get_current_name($override->tag_name);
+
+ push(@{$pattern_tracker{$tag_name}{$pattern}}, $override);
+ }
+
+ for my $tag_name (keys %pattern_tracker) {
+ for my $pattern (keys %{$pattern_tracker{$tag_name}}) {
+
+ my @overrides = @{$pattern_tracker{$tag_name}{$pattern}};
+
+ my @same_context = map { $_->position } @overrides;
+ my $line_numbers = join($SPACE, (sort @same_context));
+
+ my $override_item = $self->processable->override_file;
+
+ $self->pointed_hint('duplicate-override-context',
+ $override_item->pointer,$tag_name,"(lines $line_numbers)")
+ if @overrides > 1;
+ }
+ }
+
+ return;
+}
+
+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/Lintian/Check/Debian/LintianOverrides/Malformed.pm b/lib/Lintian/Check/Debian/LintianOverrides/Malformed.pm
new file mode 100644
index 0000000..3772889
--- /dev/null
+++ b/lib/Lintian/Check/Debian/LintianOverrides/Malformed.pm
@@ -0,0 +1,52 @@
+# debian/lintian-overrides/malformed -- lintian check script -*- perl -*-
+
+# Copyright (C) 2021 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 Lintian::Check::Debian::LintianOverrides::Malformed;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Moo;
+use namespace::clean;
+
+with 'Lintian::Check';
+
+sub always {
+ my ($self) = @_;
+
+ for my $error (@{$self->processable->override_errors}) {
+
+ my $message = $error->{message};
+ my $pointer = $error->{pointer};
+
+ $self->pointed_hint('malformed-override', $pointer, $message);
+ }
+
+ return;
+}
+
+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/Lintian/Check/Debian/LintianOverrides/Mystery.pm b/lib/Lintian/Check/Debian/LintianOverrides/Mystery.pm
new file mode 100644
index 0000000..92e6125
--- /dev/null
+++ b/lib/Lintian/Check/Debian/LintianOverrides/Mystery.pm
@@ -0,0 +1,65 @@
+# debian/lintian-overrides/mystery -- lintian check script -*- perl -*-
+
+# Copyright (C) 2021 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 Lintian::Check::Debian::LintianOverrides::Mystery;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Const::Fast;
+
+const my $ARROW => q{=>};
+
+use Moo;
+use namespace::clean;
+
+with 'Lintian::Check';
+
+sub always {
+ my ($self) = @_;
+
+ for my $override (@{$self->processable->overrides}) {
+
+ my $override_item = $self->processable->override_file;
+ my $pointer = $override_item->pointer($override->position);
+
+ my $mystery_name = $override->tag_name;
+ my $current_name = $self->profile->get_current_name($mystery_name);
+
+ $self->pointed_hint('alien-tag', $pointer, $mystery_name)
+ if !length $current_name;
+
+ $self->pointed_hint('renamed-tag', $pointer, $mystery_name, $ARROW,
+ $current_name)
+ if length $current_name
+ && $current_name ne $mystery_name;
+ }
+
+ return;
+}
+
+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/Lintian/Check/Debian/LintianOverrides/Restricted.pm b/lib/Lintian/Check/Debian/LintianOverrides/Restricted.pm
new file mode 100644
index 0000000..cc2cda4
--- /dev/null
+++ b/lib/Lintian/Check/Debian/LintianOverrides/Restricted.pm
@@ -0,0 +1,80 @@
+# debian/lintian-overrides/restricted -- lintian check script -*- perl -*-
+
+# Copyright (C) 2021 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 Lintian::Check::Debian::LintianOverrides::Restricted;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use List::SomeUtils qw(true);
+
+use Moo;
+use namespace::clean;
+
+with 'Lintian::Check';
+
+sub always {
+ my ($self) = @_;
+
+ for my $override (@{$self->processable->overrides}) {
+
+ my $override_item = $self->processable->override_file;
+ my $pointer = $override_item->pointer($override->position);
+
+ my @architectures = @{$override->architectures};
+
+ if (@architectures && $self->processable->architecture eq 'all') {
+ $self->pointed_hint('invalid-override-restriction',
+ $pointer,'Architecture list in Arch:all installable');
+ next;
+ }
+
+ my @invalid
+ = grep { !$self->data->architectures->valid_restriction($_) }
+ @architectures;
+ $self->pointed_hint('invalid-override-restriction',
+ $pointer,"Unknown architecture wildcard $_")
+ for @invalid;
+
+ next
+ if @invalid;
+
+ # count negations
+ my $negations = true { /^!/ } @architectures;
+
+ # confirm it is either all or none
+ if ($negations > 0 && $negations != @architectures) {
+ $self->pointed_hint('invalid-override-restriction',
+ $pointer,'Inconsistent architecture negation');
+ next;
+ }
+ }
+
+ return;
+}
+
+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/Lintian/Check/Debian/Maintscript.pm b/lib/Lintian/Check/Debian/Maintscript.pm
new file mode 100644
index 0000000..adee6be
--- /dev/null
+++ b/lib/Lintian/Check/Debian/Maintscript.pm
@@ -0,0 +1,73 @@
+# debian/maintscript -- lintian check script -*- perl -*-
+
+# Copyright (C) 1999 by Joey Hess
+# Copyright (C) 2016-2020 Chris Lamb <lamby@debian.org>
+# Copyright (C) 2021 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 Lintian::Check::Debian::Maintscript;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Moo;
+use namespace::clean;
+
+with 'Lintian::Check';
+
+sub visit_patched_files {
+ my ($self, $item) = @_;
+
+ return
+ unless $item->dirname eq 'debian/';
+
+ return
+ unless $item->basename =~ m{ (?: ^ | [.] ) maintscript $}x;
+
+ return
+ unless $item->is_open_ok;
+
+ open(my $fd, '<', $item->unpacked_path)
+ or die encode_utf8('Cannot open ' . $item->unpacked_path);
+
+ my $position = 1;
+ while (my $line = <$fd>) {
+
+ my $pointer = $item->pointer($position);
+
+ $self->pointed_hint('maintscript-includes-maint-script-parameters',
+ $pointer)
+ if $line =~ /--\s+"\$(?:@|{@})"\s*$/;
+
+ } continue {
+ ++$position;
+ }
+
+ close $fd;
+
+ return;
+}
+
+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/Lintian/Check/Debian/ManualPages.pm b/lib/Lintian/Check/Debian/ManualPages.pm
new file mode 100644
index 0000000..f1b654a
--- /dev/null
+++ b/lib/Lintian/Check/Debian/ManualPages.pm
@@ -0,0 +1,67 @@
+# debian/manual-pages -- lintian check script -*- perl -*-
+
+# 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 Lintian::Check::Debian::ManualPages;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use List::SomeUtils qw{none};
+
+use Moo;
+use namespace::clean;
+
+with 'Lintian::Check';
+
+sub source {
+ my ($self) = @_;
+
+ return
+ if $self->processable->native;
+
+ my $debiandir = $self->processable->patched->resolve_path('debian');
+ return
+ unless $debiandir;
+
+ my @files = grep { $_->is_file } $debiandir->descendants;
+ my @nopatches = grep { $_->name !~ m{^debian/patches/} } @files;
+
+ my @manual_pages = grep { $_->basename =~ m{\.\d$} } @nopatches;
+
+ for my $item (@manual_pages) {
+
+ my $command = $item->basename;
+ $command =~ s/ [.] \d $//x;
+
+ $self->pointed_hint('maintainer-manual-page', $item->pointer)
+ if none { $command eq $_->basename } @files;
+ }
+
+ return;
+}
+
+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/Lintian/Check/Debian/NotInstalled.pm b/lib/Lintian/Check/Debian/NotInstalled.pm
new file mode 100644
index 0000000..6e787b4
--- /dev/null
+++ b/lib/Lintian/Check/Debian/NotInstalled.pm
@@ -0,0 +1,74 @@
+# debian/not-installed -- lintian check script -*- perl -*-
+
+# Copyright (C) 2020-2021 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 Lintian::Check::Debian::NotInstalled;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Unicode::UTF8 qw(encode_utf8);
+
+use Moo;
+use namespace::clean;
+
+with 'Lintian::Check';
+
+sub visit_patched_files {
+ my ($self, $item) = @_;
+
+ return
+ unless $item->name eq 'debian/not-installed';
+
+ return
+ unless $item->is_open_ok;
+
+ open(my $fd, '<', $item->unpacked_path)
+ or die encode_utf8('Cannot open ' . $item->unpacked_path);
+
+ my $position = 1;
+ while (my $line = <$fd>) {
+
+ # disregard comments
+ next
+ if $line =~ m{^ \s* [#] }x;
+
+ # architecture triplet
+ $self->pointed_hint('unwanted-path-too-specific',
+ $item->pointer($position), $line)
+ if $line =~ m{^ usr/lib/ [^/-]+ - [^/-]+ - [^/-]+ / }x
+ && $line !~ m{^ usr/lib/ [*] / }x;
+
+ } continue {
+ ++$position;
+ }
+
+ close $fd;
+
+ return;
+}
+
+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/Lintian/Check/Debian/Patches.pm b/lib/Lintian/Check/Debian/Patches.pm
new file mode 100644
index 0000000..b9a3ec2
--- /dev/null
+++ b/lib/Lintian/Check/Debian/Patches.pm
@@ -0,0 +1,104 @@
+# debian/patches -- lintian check script -*- perl -*-
+#
+# Copyright (C) 2007 Marc Brockschmidt
+# Copyright (C) 2008 Raphael Hertzog
+# Copyright (C) 2018-2019 Chris Lamb <lamby@debian.org>
+# 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 Lintian::Check::Debian::Patches;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Path::Tiny;
+
+use Moo;
+use namespace::clean;
+
+with 'Lintian::Check';
+
+sub source {
+ my ($self) = @_;
+
+ my @patch_system;
+
+ # Get build deps so we can decide which build system the
+ # maintainer meant to use:
+ my $build_deps = $self->processable->relation('Build-Depends-All');
+
+ # Get source package format
+ my $source_format = $self->processable->fields->value('Format');
+ my $quilt_format = ($source_format =~ /3\.\d+ \(quilt\)/) ? 1 : 0;
+
+ my $debian_dir = $self->processable->patched->resolve_path('debian/');
+ return
+ unless defined $debian_dir;
+
+ my $patch_dir = $debian_dir->resolve_path('patches');
+
+ # Find debian/patches/series, assuming debian/patches is a (symlink to a)
+ # dir. There are cases, where it is a file (ctwm: #778556)
+ my $patch_series;
+ $patch_series
+ = $self->processable->patched->resolve_path('debian/patches/series');
+
+ push(@patch_system, 'dpatch')
+ if $build_deps->satisfies('dpatch');
+
+ push(@patch_system, 'quilt')
+ if $quilt_format || $build_deps->satisfies('quilt');
+
+ $self->hint('patch-system', $_) for @patch_system;
+
+ $self->hint('more-than-one-patch-system')
+ if @patch_system > 1;
+
+ if (@patch_system && !$quilt_format) {
+
+ my $readme = $debian_dir->resolve_path('README.source');
+ $self->hint('patch-system-but-no-source-readme')
+ unless defined $readme;
+ }
+
+ my @direct_changes
+ = grep { !m{^debian/} } keys %{$self->processable->diffstat};
+ if (@direct_changes) {
+
+ my $files = $direct_changes[0];
+ $files .= " and $#direct_changes more"
+ if @direct_changes > 1;
+
+ $self->hint('patch-system-but-direct-changes-in-diff', $files)
+ if @patch_system;
+
+ $self->hint('direct-changes-in-diff-but-no-patch-system', $files)
+ unless @patch_system;
+ }
+
+ return;
+}
+
+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/Lintian/Check/Debian/Patches/Count.pm b/lib/Lintian/Check/Debian/Patches/Count.pm
new file mode 100644
index 0000000..589e2ba
--- /dev/null
+++ b/lib/Lintian/Check/Debian/Patches/Count.pm
@@ -0,0 +1,54 @@
+# debian/patches/count -- lintian check script -*- perl -*-
+#
+# 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 Lintian::Check::Debian::Patches::Count;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Moo;
+use namespace::clean;
+
+with 'Lintian::Check';
+
+sub visit_patched_files {
+ my ($self, $item) = @_;
+
+ return
+ unless $item->name eq 'debian/patches/series';
+
+ my @lines = split(/\n/, $item->decoded_utf8);
+
+ # remove lines containing only comments
+ my @patches = grep { !/^\s*(?:#|$)/ } @lines;
+
+ $self->pointed_hint('number-of-patches', $item->pointer, scalar @patches);
+
+ return;
+}
+
+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/Lintian/Check/Debian/Patches/Dep3.pm b/lib/Lintian/Check/Debian/Patches/Dep3.pm
new file mode 100644
index 0000000..6624a0c
--- /dev/null
+++ b/lib/Lintian/Check/Debian/Patches/Dep3.pm
@@ -0,0 +1,105 @@
+# debian/patches/dep3 -- lintian check script -*- perl -*-
+
+# 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 Lintian::Check::Debian::Patches::Dep3;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Const::Fast;
+use List::SomeUtils qw(any none);
+use Syntax::Keyword::Try;
+use Unicode::UTF8 qw(valid_utf8 decode_utf8);
+
+use Lintian::Deb822;
+
+const my $EMPTY => q{};
+
+use Moo;
+use namespace::clean;
+
+with 'Lintian::Check';
+
+sub visit_patched_files {
+ my ($self, $item) = @_;
+
+ return
+ unless $item->name =~ m{^debian/patches/};
+
+ return
+ unless $item->is_file;
+
+ return
+ if $item->name eq 'debian/patches/series'
+ || $item->name eq 'debian/patches/README';
+
+ my $bytes = $item->bytes;
+ return
+ unless length $bytes;
+
+ my ($headerbytes) = split(/^---/m, $bytes, 2);
+
+ return
+ unless valid_utf8($headerbytes);
+
+ my $header = decode_utf8($headerbytes);
+ return
+ unless length $header;
+
+ my $deb822 = Lintian::Deb822->new;
+
+ my @sections;
+ try {
+ @sections = $deb822->parse_string($header);
+
+ } catch {
+ return;
+ }
+
+ return
+ unless @sections;
+
+ # use last mention when present multiple times
+ my $origin = $deb822->last_mention('Origin');
+
+ my ($category) = split(m{\s*,\s*}, $origin, 2);
+ $category //= $EMPTY;
+ return
+ if any { $category eq $_ } qw(upstream backport);
+
+ $self->pointed_hint('patch-not-forwarded-upstream', $item->pointer)
+ if $deb822->last_mention('Forwarded') eq 'no'
+ || none { length } (
+ $deb822->last_mention('Applied-Upstream'),
+ $deb822->last_mention('Bug'),
+ $deb822->last_mention('Forwarded')
+ );
+
+ return;
+}
+
+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/Lintian/Check/Debian/Patches/Dpatch.pm b/lib/Lintian/Check/Debian/Patches/Dpatch.pm
new file mode 100644
index 0000000..337fa53
--- /dev/null
+++ b/lib/Lintian/Check/Debian/Patches/Dpatch.pm
@@ -0,0 +1,150 @@
+# debian/patches -- lintian check script -*- perl -*-
+#
+# Copyright (C) 2007 Marc Brockschmidt
+# Copyright (C) 2008 Raphael Hertzog
+# Copyright (C) 2018-2019 Chris Lamb <lamby@debian.org>
+# 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 Lintian::Check::Debian::Patches::Dpatch;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Const::Fast;
+use Unicode::UTF8 qw(encode_utf8);
+
+use Moo;
+use namespace::clean;
+
+with 'Lintian::Check';
+
+const my $EMPTY => q{};
+const my $SPACE => q{ };
+
+sub source {
+ my ($self) = @_;
+
+ my $build_deps = $self->processable->relation('Build-Depends-All');
+ return
+ unless $build_deps->satisfies('dpatch');
+
+ my $patch_dir
+ = $self->processable->patched->resolve_path('debian/patches/');
+ return
+ unless defined $patch_dir;
+
+ $self->hint('package-uses-deprecated-dpatch-patch-system');
+
+ my @list_files
+ = grep {$_->basename =~ m/^00list/ && $_->is_open_ok}
+ $patch_dir->children;
+
+ $self->hint('dpatch-build-dep-but-no-patch-list')
+ unless @list_files;
+
+ my $options_file = $patch_dir->resolve_path('00options');
+
+ my $list_uses_cpp = 0;
+ $list_uses_cpp = 1
+ if defined $options_file
+ && $options_file->decoded_utf8 =~ /DPATCH_OPTION_CPP=1/;
+
+ for my $file (@list_files) {
+ my @patches;
+
+ open(my $fd, '<', $file->unpacked_path)
+ or die encode_utf8('Cannot open ' . $file->unpacked_path);
+
+ while(my $line = <$fd>) {
+ chomp $line;
+
+ #ignore comments or CPP directive
+ next
+ if $line =~ /^\#/;
+
+ # remove C++ style comments
+ $line =~ s{//.*}{}
+ if $list_uses_cpp;
+
+ if ($list_uses_cpp && $line =~ m{/\*}) {
+
+ # remove C style comments
+ $line .= <$fd> while ($line !~ m{\*/});
+
+ $line =~ s{/\*[^*]*\*/}{}g;
+ }
+
+ #ignore blank lines
+ next
+ if $line =~ /^\s*$/;
+
+ push @patches, split($SPACE, $line);
+ }
+ close($fd);
+
+ for my $patch_name (@patches) {
+
+ my $patch_file = $patch_dir->child($patch_name);
+ $patch_file = $patch_dir->child("${patch_name}.dpatch")
+ unless defined $patch_file;
+
+ unless (defined $patch_file) {
+ $self->hint('dpatch-index-references-non-existent-patch',
+ $patch_name);
+ next;
+ }
+
+ next
+ unless $patch_file->is_open_ok;
+
+ my $description = $EMPTY;
+ open(my $fd, '<', $patch_file->unpacked_path)
+ or die encode_utf8('Cannot open ' . $patch_file->unpacked_path);
+
+ while (my $line = <$fd>) {
+ # stop if something looking like a patch
+ # starts:
+ last
+ if $line =~ /^---/;
+ # note comment if we find a proper one
+ $description .= $1
+ if $line =~ /^\#+\s*DP:\s*(\S.*)$/
+ && $1 !~ /^no description\.?$/i;
+ $description .= $1
+ if $line =~ /^\# (?:Description|Subject): (.*)/;
+ }
+ close($fd);
+
+ $self->pointed_hint('dpatch-missing-description',
+ $patch_file->pointer)
+ unless length $description;
+ }
+ }
+
+ return;
+}
+
+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/Lintian/Check/Debian/Patches/Quilt.pm b/lib/Lintian/Check/Debian/Patches/Quilt.pm
new file mode 100644
index 0000000..2e78055
--- /dev/null
+++ b/lib/Lintian/Check/Debian/Patches/Quilt.pm
@@ -0,0 +1,290 @@
+# debian/patches/quilt -- lintian check script -*- perl -*-
+#
+# Copyright (C) 2007 Marc Brockschmidt
+# Copyright (C) 2008 Raphael Hertzog
+# Copyright (C) 2018-2019 Chris Lamb <lamby@debian.org>
+# 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 Lintian::Check::Debian::Patches::Quilt;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Const::Fast;
+use List::SomeUtils qw(any);
+use Unicode::UTF8 qw(decode_utf8 encode_utf8);
+
+use Lintian::IPC::Run3 qw(safe_qx);
+use Lintian::Spelling qw(check_spelling);
+
+use Moo;
+use namespace::clean;
+
+with 'Lintian::Check';
+
+const my $PATCH_DESC_TEMPLATE =>
+ 'TODO: Put a short summary on the line above and replace this paragraph';
+const my $EMPTY => q{};
+
+sub spelling_tag_emitter {
+ my ($self, $tag_name, $item, @orig_args) = @_;
+
+ my $pointer = $item->pointer($.);
+
+ return sub {
+ return $self->pointed_hint($tag_name, $pointer, @orig_args, @_);
+ };
+}
+
+sub source {
+ my ($self) = @_;
+
+ my $build_deps = $self->processable->relation('Build-Depends-All');
+
+ my $source_format = $self->processable->fields->value('Format');
+ my $quilt_format = ($source_format =~ /3\.\d+ \(quilt\)/) ? 1 : 0;
+
+ my $debian_dir = $self->processable->patched->resolve_path('debian/');
+ return
+ unless defined $debian_dir;
+
+ my $patch_dir = $debian_dir->resolve_path('patches');
+ my %known_files;
+
+ # Find debian/patches/series, assuming debian/patches is a (symlink to a)
+ # dir. There are cases, where it is a file (ctwm: #778556)
+ my $patch_series;
+ $patch_series
+ = $self->processable->patched->resolve_path('debian/patches/series');
+
+ # 3.0 (quilt) sources do not need quilt
+ unless ($quilt_format) {
+
+ $self->hint('quilt-build-dep-but-no-series-file')
+ if $build_deps->satisfies('quilt')
+ && (!defined $patch_series || !$patch_series->is_open_ok);
+
+ $self->pointed_hint('quilt-series-but-no-build-dep',
+ $patch_series->pointer)
+ if $patch_series
+ && $patch_series->is_file
+ && !$build_deps->satisfies('quilt');
+ }
+
+ return
+ unless $quilt_format || $build_deps->satisfies('quilt');
+
+ if ($patch_series && $patch_series->is_open_ok) {
+
+ my @patch_names;
+
+ open(my $series_fd, '<', $patch_series->unpacked_path)
+ or die encode_utf8('Cannot open ' . $patch_series->unpacked_path);
+
+ my $position = 1;
+ while (my $line = <$series_fd>) {
+
+ # Strip comment
+ $line =~ s/(?:^|\s+)#.*$//;
+
+ if (rindex($line,"\n") < 0) {
+ $self->pointed_hint('quilt-series-without-trailing-newline',
+ $patch_series->pointer);
+ }
+
+ # trim both ends
+ $line =~ s/^\s+|\s+$//g;
+
+ next
+ unless length $line;
+
+ if ($line =~ m{^(\S+)\s+(\S.*)$}) {
+
+ my $patch = $1;
+ my $patch_options = $2;
+
+ push(@patch_names, $patch);
+
+ $self->pointed_hint('quilt-patch-with-non-standard-options',
+ $patch_series->pointer($position), $line)
+ unless $patch_options eq '-p1';
+
+ } else {
+ push(@patch_names, $line);
+ }
+
+ } continue {
+ ++$position;
+ }
+
+ close $series_fd;
+
+ my @patch_files;
+ for my $name (@patch_names) {
+
+ my $item = $patch_dir->resolve_path($name);
+
+ if (defined $item && $item->is_file) {
+ push(@patch_files, $item);
+
+ } else {
+ $self->pointed_hint(
+ 'quilt-series-references-non-existent-patch',
+ $patch_series->pointer, $name);
+ }
+ }
+
+ for my $item (@patch_files) {
+
+ next
+ unless $item->is_open_ok;
+
+ my $description = $EMPTY;
+ my $has_template_description = 0;
+
+ open(my $patch_fd, '<', $item->unpacked_path)
+ or die encode_utf8('Cannot open ' . $item->unpacked_path);
+
+ while (my $line = <$patch_fd>) {
+
+ # stop if something looking like a patch starts:
+ last
+ if $line =~ /^---/;
+
+ next
+ if $line =~ /^\s*$/;
+
+ # Skip common "lead-in" lines
+ $description .= $line
+ unless $line =~ m{^(?:Index: |=+$|diff .+|index |From: )};
+
+ $has_template_description = 1
+ if $line =~ / \Q$PATCH_DESC_TEMPLATE\E /msx;
+ }
+ close $patch_fd;
+
+ $self->pointed_hint('quilt-patch-missing-description',
+ $item->pointer)
+ unless length $description;
+
+ $self->pointed_hint('quilt-patch-using-template-description',
+ $item->pointer)
+ if $has_template_description;
+
+ $self->check_patch($item, $description);
+ }
+ }
+
+ if ($quilt_format) { # 3.0 (quilt) specific checks
+ # Format 3.0 packages may generate a debian-changes-$version patch
+ my $version = $self->processable->fields->value('Version');
+ my $patch_header= $debian_dir->resolve_path('source/patch-header');
+ my $versioned_patch;
+
+ $versioned_patch= $patch_dir->resolve_path("debian-changes-$version")
+ if $patch_dir;
+
+ if (defined $versioned_patch && $versioned_patch->is_file) {
+
+ $self->pointed_hint('format-3.0-but-debian-changes-patch',
+ $versioned_patch->pointer)
+ if !defined $patch_header || !$patch_header->is_file;
+ }
+ }
+
+ if ($patch_dir and $patch_dir->is_dir and $source_format ne '2.0') {
+ # Check all series files, including $vendor.series
+ for my $item ($patch_dir->children) {
+ next
+ unless $item->name =~ /\/(.+\.)?series$/;
+ next
+ unless $item->is_open_ok;
+
+ $known_files{$item->basename}++;
+
+ open(my $fd, '<', $item->unpacked_path)
+ or die encode_utf8('Cannot open ' . $item->unpacked_path);
+
+ while (my $line = <$fd>) {
+ $known_files{$1}++
+ if $line =~ m{^\s*(?:#+\s*)?(\S+)};
+ }
+ close($fd);
+
+ $self->pointed_hint('package-uses-vendor-specific-patch-series',
+ $item->pointer)
+ if $item->name =~ m{ [.]series $}x;
+ }
+
+ for my $item ($patch_dir->descendants) {
+ next
+ if $item->basename =~ /^README(\.patches)?$/
+ || $item->basename =~ /\.in/g;
+
+ # Use path relative to debian/patches for "subdir/foo"
+ my $name = substr($item, length $patch_dir);
+
+ $self->pointed_hint(
+ 'patch-file-present-but-not-mentioned-in-series',
+ $item->pointer)
+ unless $known_files{$name} || $item->is_dir;
+ }
+ }
+
+ return;
+}
+
+# Checks on patches common to all build systems.
+sub check_patch {
+ my ($self, $item, $description) = @_;
+
+ unless (any { /(spelling|typo)/i } ($item->name, $description)) {
+ my $tag_emitter
+ = $self->spelling_tag_emitter('spelling-error-in-patch-description',
+ $item);
+ check_spelling($self->data, $description,
+ $self->group->spelling_exceptions,
+ $tag_emitter, 0);
+ }
+
+ # Use --strip=1 to strip off the first layer of directory in case
+ # the parent directory in which the patches were generated was
+ # named "debian". This will produce false negatives for --strip=0
+ # patches that modify files in the debian/* directory, but as of
+ # 2010-01-01, all cases where the first level of the patch path is
+ # "debian/" in the archive are false positives.
+ my $bytes = safe_qx('lsdiff', '--strip=1', $item->unpacked_path);
+ my $output = decode_utf8($bytes);
+
+ my @debian_files = ($output =~ m{^((?:\./)?debian/.*)$}ms);
+
+ $self->pointed_hint('patch-modifying-debian-files', $item->pointer, $_)
+ for @debian_files;
+
+ return;
+}
+
+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/Lintian/Check/Debian/PoDebconf.pm b/lib/Lintian/Check/Debian/PoDebconf.pm
new file mode 100644
index 0000000..333fee5
--- /dev/null
+++ b/lib/Lintian/Check/Debian/PoDebconf.pm
@@ -0,0 +1,391 @@
+# debian/po-debconf -- lintian check script -*- perl -*-
+
+# Copyright (C) 2002-2004 by Denis Barbier <barbier@linuxfr.org>
+# Copyright (C) 2021 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 Lintian::Check::Debian::PoDebconf;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Const::Fast;
+use Cwd qw(realpath);
+use File::Temp();
+use IPC::Run3;
+use Syntax::Keyword::Try;
+use Unicode::UTF8 qw(encode_utf8);
+
+use Lintian::IPC::Run3 qw(safe_qx);
+
+use Moo;
+use namespace::clean;
+
+with 'Lintian::Check';
+
+const my $EMPTY => q{};
+
+sub source {
+ my ($self) = @_;
+
+ my $processable = $self->processable;
+
+ my $has_template = 0;
+ my @lang_templates;
+ my $full_translation = 0;
+
+ my $debian_dir = $processable->patched->resolve_path('debian/');
+ return
+ unless $debian_dir;
+
+ my $debian_po_dir = $debian_dir->resolve_path('po');
+ my ($templ_pot_path, $potfiles_in_path);
+
+ if ($debian_po_dir and $debian_po_dir->is_dir) {
+ $templ_pot_path = $debian_po_dir->resolve_path('templates.pot');
+ $potfiles_in_path = $debian_po_dir->resolve_path('POTFILES.in');
+ }
+
+ # First, check whether this package seems to use debconf but not
+ # po-debconf. Read the templates file and look at the template
+ # names it provides, since some shared templates aren't
+ # translated.
+ for my $item ($debian_dir->children) {
+ next
+ unless $item->is_open_ok;
+
+ if ($item->basename =~ m/^(.+\.)?templates(\..+)?$/) {
+ if ($item->basename =~ m/templates\.\w\w(_\w\w)?$/) {
+ push(@lang_templates, $item);
+
+ open(my $fd, '<', $item->unpacked_path)
+ or die encode_utf8('Cannot open ' . $item->unpacked_path);
+
+ while (my $line = <$fd>) {
+
+ $self->pointed_hint('untranslatable-debconf-templates',
+ $item->pointer($.))
+ if $line =~ /^Description: (.+)/i
+ && $1 !~/for internal use/;
+ }
+
+ close $fd;
+
+ } else {
+ open(my $fd, '<', $item->unpacked_path)
+ or die encode_utf8('Cannot open ' . $item->unpacked_path);
+
+ my $in_template = 0;
+ my $saw_tl_note = 0;
+ while (my $line = <$fd>) {
+ chomp $line;
+
+ $self->pointed_hint('translated-default-field',
+ $item->pointer($.))
+ if $line =~ m{^_Default(?:Choice)?: [^\[]*$}
+ && !$saw_tl_note;
+
+ $self->pointed_hint('untranslatable-debconf-templates',
+ $item->pointer($.))
+ if $line =~ /^Description: (.+)/i
+ && $1 !~/for internal use/;
+
+ if ($line =~ /^#/) {
+ # Is this a comment for the translators?
+ $saw_tl_note = 1
+ if $line =~ /translators/i;
+
+ next;
+ }
+
+ # If it is not a continuous comment immediately before the
+ # _Default(Choice) field, we don't care about it.
+ $saw_tl_note = 0;
+
+ if ($line =~ /^Template: (\S+)/i) {
+ my $template = $1;
+ next
+ if $template eq 'shared/packages-wordlist'
+ or $template eq 'shared/packages-ispell';
+
+ next
+ if $template =~ m{/languages$};
+
+ $in_template = 1;
+
+ } elsif ($in_template && $line =~ /^_?Description: (.+)/i){
+ my $description = $1;
+ next
+ if $description =~ /for internal use/;
+ $has_template = 1;
+
+ } elsif ($in_template && !length($line)) {
+ $in_template = 0;
+ }
+ }
+
+ close($fd);
+ }
+ }
+ }
+
+ #TODO: check whether all templates are named in TEMPLATES.pot
+ if ($has_template) {
+ if (not $debian_po_dir or not $debian_po_dir->is_dir) {
+ $self->hint('not-using-po-debconf');
+ return;
+ }
+ } else {
+ return;
+ }
+
+ # If we got here, we're using po-debconf, so there shouldn't be any stray
+ # language templates left over from debconf-mergetemplate.
+ for my $item (@lang_templates) {
+ $self->pointed_hint('stray-translated-debconf-templates',
+ $item->pointer)
+ unless $item->basename =~ m{ templates[.]in$}x;
+ }
+
+ my $missing_files = 0;
+
+ if ($potfiles_in_path and $potfiles_in_path->is_open_ok) {
+
+ open(my $fd, '<', $potfiles_in_path->unpacked_path)
+ or
+ die encode_utf8('Cannot open ' . $potfiles_in_path->unpacked_path);
+
+ my $position = 1;
+ while (my $line = <$fd>) {
+ chomp $line;
+
+ next
+ if $line =~ /^\s*\#/;
+
+ $line =~ s/.*\]\s*//;
+
+ # Cannot check files which are not under debian/
+ # m,^\.\./, or
+ next
+ if $line eq $EMPTY;
+
+ my $pointer = $potfiles_in_path->pointer($position);
+
+ my $po_path = $debian_dir->resolve_path($line);
+ unless ($po_path and $po_path->is_file) {
+
+ $self->pointed_hint('missing-file-from-potfiles-in',
+ $pointer, $line);
+ $missing_files = 1;
+ }
+
+ } continue {
+ ++$position;
+ }
+
+ close $fd;
+
+ } else {
+ $self->hint('missing-potfiles-in');
+ $missing_files = 1;
+ }
+ if (not $templ_pot_path or not $templ_pot_path->is_open_ok) {
+ # We use is_open_ok here, because if it is present, we will
+ # (have a subprocess) open it if the POTFILES.in file also
+ # existed.
+ $self->hint('missing-templates-pot');
+ $missing_files = 1;
+ }
+
+ if ($missing_files == 0) {
+ my $temp_obj
+ = File::Temp->newdir('lintian-po-debconf-XXXXXX',TMPDIR => 1);
+ my $abs_tempdir = realpath($temp_obj->dirname)
+ or croak('Cannot resolve ' . $temp_obj->dirname . ": $!");
+ # We need an extra level of dirs, as intltool (in)directly
+ # tries to use files in ".." if they exist
+ # (e.g. ../templates.h).
+ # - In fact, we also need to copy debian/templates into
+ # this "fake package directory", since intltool-updates
+ # sometimes want to write files to "../templates" based
+ # on the contents of the package. (See #778558)
+ my $tempdir = "$abs_tempdir/po";
+ my $test_pot = "$tempdir/test.pot";
+ my $tempdir_templates = "${abs_tempdir}/templates";
+ my $d_templates = $debian_dir->resolve_path('templates');
+
+ # Create our extra level
+ mkdir($tempdir)
+ or die encode_utf8('Cannot create directory ' . $tempdir);
+
+ # Copy the templates dir because intltool-update might
+ # write to it.
+ safe_qx(
+ qw{cp -a --reflink=auto --},
+ $d_templates->unpacked_path,
+ $tempdir_templates
+ )if $d_templates;
+
+ my $error;
+ my %save = %ENV;
+ my $cwd = Cwd::getcwd;
+
+ try {
+ $ENV{INTLTOOL_EXTRACT}
+ = '/usr/share/intltool-debian/intltool-extract';
+ # use of $debian_po is safe; we accessed two children by now.
+ $ENV{srcdir} = $debian_po_dir->unpacked_path;
+
+ chdir($tempdir)
+ or die encode_utf8('Cannot change directory ' . $tempdir);
+
+ # generate a "test.pot" in a tempdir
+ my @intltool = (
+ '/usr/share/intltool-debian/intltool-update',
+ '--gettext-package=test','--pot'
+ );
+ safe_qx(@intltool);
+ die encode_utf8("system @intltool failed: $?")
+ if $?;
+
+ } catch {
+ # catch any error
+ $error = $@;
+
+ } finally {
+ # restore environment
+ %ENV = %save;
+
+ # restore working directory
+ chdir($cwd)
+ or die encode_utf8('Cannot change directory ' . $cwd);
+ }
+
+ # output could be helpful to user but is currently not printed
+
+ if ($error) {
+ $self->pointed_hint('invalid-potfiles-in',
+ $potfiles_in_path->pointer);
+ return;
+ }
+
+ # throw away output on the following commands
+ $error = undef;
+
+ try {
+ # compare our "test.pot" with the existing "templates.pot"
+ my @testleft = (
+ 'msgcmp', '--use-untranslated',
+ $test_pot, $templ_pot_path->unpacked_path
+ );
+ safe_qx(@testleft);
+ die encode_utf8("system @testleft failed: $?")
+ if $?;
+
+ # is this not equivalent to the previous command? - FL
+ my @testright = (
+ 'msgcmp', '--use-untranslated',
+ $templ_pot_path->unpacked_path, $test_pot
+ );
+ safe_qx(@testright);
+ die encode_utf8("system @testright failed: $?")
+ if $?;
+
+ } catch {
+ # catch any error
+ $error = $@;
+ }
+
+ $self->pointed_hint('newer-debconf-templates',$templ_pot_path->pointer)
+ if length $error;
+ }
+
+ return
+ unless $debian_po_dir;
+
+ for my $po_item ($debian_po_dir->children) {
+
+ next
+ unless $po_item->basename =~ m/\.po$/ || $po_item->is_dir;
+
+ $self->pointed_hint('misnamed-po-file', $po_item->pointer)
+ unless (
+ $po_item->basename =~ /^[a-z]{2,3}(_[A-Z]{2})?(?:\@[^\.]+)?\.po$/);
+
+ next
+ unless $po_item->is_open_ok;
+
+ my $bytes = $po_item->bytes;
+
+ $self->pointed_hint('debconf-translation-using-general-list',
+ $po_item->pointer)
+ if $bytes =~ /Language\-Team:.*debian-i18n\@lists\.debian\.org/i;
+
+ unless ($bytes =~ /^msgstr/m) {
+
+ $self->pointed_hint('invalid-po-file', $po_item->pointer);
+ next;
+ }
+
+ if ($bytes =~ /charset=(.*?)\\n/) {
+
+ my $charset = ($1 eq 'CHARSET' ? $EMPTY : $1);
+
+ $self->pointed_hint('unknown-encoding-in-po-file',
+ $po_item->pointer)
+ unless length $charset;
+ }
+
+ my $error;
+
+ my $stats;
+
+ delete local $ENV{$_}
+ for grep { $_ ne 'PATH' && $_ ne 'TMPDIR' } keys %ENV;
+ local $ENV{LC_ALL} = 'C';
+
+ my @command = (
+ 'msgfmt', '-o', '/dev/null', '--statistics',
+ $po_item->unpacked_path
+ );
+
+ run3(\@command, \undef, \undef, \$stats);
+
+ $self->pointed_hint('invalid-po-file', $po_item->pointer)
+ if $?;
+
+ $stats //= $EMPTY;
+
+ $full_translation = 1
+ if $stats =~ m/^\w+ \w+ \w+\.$/;
+ }
+
+ $self->hint('no-complete-debconf-translation')
+ if !$full_translation;
+
+ return;
+}
+
+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/Lintian/Check/Debian/Readme.pm b/lib/Lintian/Check/Debian/Readme.pm
new file mode 100644
index 0000000..c8fd030
--- /dev/null
+++ b/lib/Lintian/Check/Debian/Readme.pm
@@ -0,0 +1,176 @@
+# debian/readme -- lintian check script -*- perl -*-
+
+# Copyright (C) 1998 Richard Braakman
+# Copyright (C) 2021 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 Lintian::Check::Debian::Readme;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Const::Fast;
+use Unicode::UTF8 qw(encode_utf8);
+
+use Lintian::Spelling qw(check_spelling);
+
+use Moo;
+use namespace::clean;
+
+with 'Lintian::Check';
+
+const my $EMPTY => q{};
+const my $VERTICAL_BAR => q{|};
+
+sub spelling_tag_emitter {
+ my ($self, $tag_name, $item, @orig_args) = @_;
+
+ my $pointer = $item->pointer($.);
+
+ return sub {
+ return $self->pointed_hint($tag_name, $pointer, @orig_args, @_);
+ };
+}
+
+sub open_readme {
+ my ($pkg_name, $processable) = @_;
+
+ my $doc_dir
+ = $processable->installed->resolve_path("usr/share/doc/${pkg_name}/");
+
+ if (defined $doc_dir) {
+
+ for my $name (
+ qw(README.Debian.gz README.Debian README.debian.gz README.debian)){
+
+ my $path = $doc_dir->child($name);
+
+ next
+ unless $path && $path->is_open_ok;
+
+ if ($name =~ m/\.gz$/) {
+ open(my $fd, '<:gzip', $path->unpacked_path)
+ or die encode_utf8('Cannot open ' . $path->unpacked_path);
+
+ return $fd;
+ }
+
+ open(my $fd, '<', $path->unpacked_path)
+ or die encode_utf8('Cannot open ' . $path->unpacked_path);
+
+ return $fd;
+ }
+ }
+
+ return undef;
+}
+
+sub installable {
+ my ($self) = @_;
+
+ my $pkg_name = $self->processable->name;
+ my $group = $self->group;
+
+ my $doc_dir
+ = $self->processable->installed->resolve_path(
+ "usr/share/doc/${pkg_name}/");
+
+ return
+ unless defined $doc_dir;
+
+ my $item;
+ my $fd;
+
+ for my $name (
+ qw(README.Debian.gz README.Debian README.debian.gz README.debian)){
+
+ $item = $doc_dir->child($name);
+
+ next
+ unless $item && $item->is_open_ok;
+
+ if ($name =~ m/\.gz$/) {
+ open($fd, '<:gzip', $item->unpacked_path)
+ or die encode_utf8('Cannot open ' . $item->unpacked_path);
+
+ last;
+ }
+
+ open($fd, '<', $item->unpacked_path)
+ or die encode_utf8('Cannot open ' . $item->unpacked_path);
+
+ last;
+ }
+
+ return
+ unless defined $item
+ && defined $fd;
+
+ my $readme = $EMPTY;
+
+ my $position = 1;
+ while (my $line = <$fd>) {
+
+ my $pointer = $item->pointer($position);
+
+ $self->pointed_hint('readme-debian-mentions-usr-doc', $pointer)
+ if $line =~ m{ /usr/doc \b }x;
+
+ $readme .= $line;
+
+ } continue {
+ ++$position;
+ }
+
+ close $fd;
+
+ my @template =(
+ 'Comments regarding the Package',
+ 'So far nothing to say',
+ '<possible notes regarding this package - if none, delete this file>',
+ 'Automatically generated by debmake'
+ );
+
+ my $regex = join($VERTICAL_BAR, @template);
+
+ if ($readme =~ m/$regex/i) {
+ $self->pointed_hint('readme-debian-contains-debmake-template',
+ $item->pointer);
+
+ } elsif ($readme =~ m/^\s*-- [^<]*<([^> ]+.\@[^>.]*)>/m) {
+
+ my $address = $1;
+
+ $self->pointed_hint('readme-debian-contains-invalid-email-address',
+ $item->pointer, $address);
+ }
+
+ check_spelling($self->data,$readme,$group->spelling_exceptions,
+ $self->spelling_tag_emitter('spelling-error-in-readme-debian', $item));
+
+ return;
+}
+
+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/Lintian/Check/Debian/Rules.pm b/lib/Lintian/Check/Debian/Rules.pm
new file mode 100644
index 0000000..ffae6cb
--- /dev/null
+++ b/lib/Lintian/Check/Debian/Rules.pm
@@ -0,0 +1,671 @@
+# debian/rules -- lintian check script -*- perl -*-
+
+# Copyright (C) 2006 Russ Allbery <rra@debian.org>
+# Copyright (C) 2005 Rene van Bevern <rvb@pro-linux.de>
+# Copyright (C) 2019-2020 Chris Lamb <lamby@debian.org>
+# Copyright (C) 2021 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.
+
+package Lintian::Check::Debian::Rules;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Carp qw(croak);
+use Const::Fast;
+use List::Compare;
+use List::SomeUtils qw(any none uniq);
+use Unicode::UTF8 qw(encode_utf8);
+
+use Moo;
+use namespace::clean;
+
+with 'Lintian::Check';
+
+const my $EMPTY => q{};
+const my $SPACE => q{ };
+const my $PERCENT => q{%};
+
+my @py3versions = qw(3.4 3.5 3.6 3.7);
+
+my $PYTHON_DEPEND= 'python2:any | python2-dev:any';
+my $PYTHON3_DEPEND
+ = 'python3:any | python3-dev:any | python3-all:any | python3-all-dev:any';
+my $PYTHON2X_DEPEND = 'python2.7:any | python2.7-dev:any';
+my $PYTHON3X_DEPEND
+ = join(' | ',map { "python${_}:any | python${_}-dev:any" } @py3versions);
+my $ANYPYTHON_DEPEND
+ = "$PYTHON_DEPEND | $PYTHON2X_DEPEND | $PYTHON3_DEPEND | $PYTHON3X_DEPEND";
+my $PYTHON3_ALL_DEPEND
+ = 'python3-all:any | python3-all-dev:any | python3-all-dbg:any';
+
+my %TAG_FOR_POLICY_TARGET = (
+ build => 'debian-rules-missing-required-target',
+ binary => 'debian-rules-missing-required-target',
+ 'binary-arch' => 'debian-rules-missing-required-target',
+ 'binary-indep' => 'debian-rules-missing-required-target',
+ clean => 'debian-rules-missing-required-target',
+ 'build-arch' => 'debian-rules-missing-required-target',
+ 'build-indep' => 'debian-rules-missing-required-target'
+);
+
+# Rules about required debhelper command ordering. Each command is put into a
+# class and the tag is issued if they're called in the wrong order for the
+# classes. Unknown commands won't trigger this flag.
+my %debhelper_order = (
+ dh_makeshlibs => 1,
+ dh_shlibdeps => 2,
+ dh_installdeb => 2,
+ dh_gencontrol => 2,
+ dh_builddeb => 3
+);
+
+sub source {
+ my ($self) = @_;
+
+ my $debian_dir = $self->processable->patched->resolve_path('debian');
+
+ my $rules;
+ $rules = $debian_dir->child('rules')
+ if defined $debian_dir;
+
+ return
+ unless defined $rules;
+
+ # Policy could be read as allowing debian/rules to be a symlink to
+ # some other file, and in a native Debian package it could be a
+ # symlink to a file that we didn't unpack.
+ $self->pointed_hint('debian-rules-is-symlink', $rules->pointer)
+ if $rules->is_symlink;
+
+ # dereference symbolic links
+ $rules = $rules->follow;
+
+ return
+ unless defined $rules;
+
+ $self->pointed_hint('debian-rules-not-executable', $rules->pointer)
+ unless $rules->is_executable;
+
+ my $KNOWN_MAKEFILES= $self->data->load('rules/known-makefiles', '\|\|');
+ my $DEPRECATED_MAKEFILES= $self->data->load('rules/deprecated-makefiles');
+
+ my $architecture = $self->processable->fields->value('Architecture');
+
+ # If the version field is missing, we assume a neutral non-native one.
+ my $version = $self->processable->fields->value('Version') || '0-1';
+
+ # Check for required #!/usr/bin/make -f opening line. Allow -r or -e; a
+ # strict reading of Policy doesn't allow either, but they seem harmless.
+ $self->pointed_hint('debian-rules-not-a-makefile', $rules->pointer)
+ unless $rules->hashbang =~ m{^/usr/bin/make\s+-[re]?f[re]?$};
+
+ # Certain build tools must be listed in Build-Depends even if there are no
+ # arch-specific packages because they're required in order to run the clean
+ # rule. (See Policy 7.6.) The following is a list of package dependencies;
+ # regular expressions that, if they match anywhere in the debian/rules file,
+ # say that this package is allowed (and required) in Build-Depends; and
+ # optional tags to use for reporting the problem if some information other
+ # than the default is required.
+ my %GLOBAL_CLEAN_DEPENDS = (
+ 'ant:any' => [qr{^include\s*/usr/share/cdbs/1/rules/ant\.mk}],
+ 'cdbs:any' => [
+ qr{^include\s+/usr/share/cdbs/},
+ qr{^include\s+/usr/share/R/debian/r-cran\.mk}
+ ],
+ 'dbs:any' => [qr{^include\s+/usr/share/dbs/}],
+ 'dh-make-php:any' => [qr{^include\s+/usr/share/cdbs/1/class/pear\.mk}],
+ 'debhelper:any | debhelper-compat:any' =>[
+ qr{^include\s+/usr/share/cdbs/1/rules/debhelper\.mk},
+ qr{^include\s+/usr/share/R/debian/r-cran\.mk}
+ ],
+ 'dpatch:any' => [
+ qr{^include\s+/usr/share/dpatch/},
+ qr{^include\s+/usr/share/cdbs/1/rules/dpatch\.mk}
+ ],
+ 'gnome-pkg-tools:any | dh-sequence-gnome:any' =>
+ [qr{^include\s+/usr/share/gnome-pkg-tools/}],
+ 'quilt:any' => [
+ qr{^include\s+/usr/share/quilt/},
+ qr{^include\s+/usr/share/cdbs/1/rules/patchsys-quilt\.mk}
+ ],
+ 'mozilla-devscripts:any' =>
+ [qr{^include\s+/usr/share/mozilla-devscripts/}],
+ 'ruby-pkg-tools:any' =>
+ [qr{^include\s+/usr/share/ruby-pkg-tools/1/class/}],
+ 'r-base-dev:any' => [qr{^include\s+/usr/share/R/debian/r-cran\.mk}],
+ $ANYPYTHON_DEPEND =>[qr{/usr/share/cdbs/1/class/python-distutils\.mk}],
+ );
+
+ # A list of packages; regular expressions that, if they match anywhere in the
+ # debian/rules file, this package must be listed in either Build-Depends or
+ # Build-Depends-Indep as appropriate; and optional tags as above.
+ my %GLOBAL_DEPENDS = (
+ 'dh-ocaml:any, ocaml-nox:any | ocaml:any' =>
+ [qr/^\t\s*dh_ocaml(?:init|doc)\s/],
+ 'debhelper:any | debhelper-compat:any | dh-autoreconf:any' =>
+ [qr/^\t\s*dh_autoreconf(?:_clean)?\s/],
+ );
+
+ # Similarly, this list of packages, regexes, and optional tags say that if the
+ # regex matches in one of clean, build-arch, binary-arch, or a rule they
+ # depend on, this package is allowed (and required) in Build-Depends.
+ my %RULE_CLEAN_DEPENDS =(
+ 'ant:any' => [qr/^\t\s*(\S+=\S+\s+)*ant\s/],
+ 'debhelper:any | debhelper-compat:any' =>
+ [qr/^\t\s*dh_(?!autoreconf).+/],
+ 'dh-ocaml:any, ocaml-nox:any | ocaml:any' =>[qr/^\t\s*dh_ocamlinit\s/],
+ 'dpatch:any' => [qr/^\t\s*(\S+=\S+\s+)*dpatch\s/],
+ 'po-debconf:any' => [qr/^\t\s*debconf-updatepo\s/],
+ $PYTHON_DEPEND => [qr/^\t\s*python\s/],
+ $PYTHON3_DEPEND => [qr/^\t\s*python3\s/],
+ $ANYPYTHON_DEPEND => [qr/\ssetup\.py\b/],
+ 'quilt:any' => [qr/^\t\s*(\S+=\S+\s+)*quilt\s/],
+ );
+
+ my $build_all = $self->processable->relation('Build-Depends-All');
+ my $build_all_norestriction
+ = $self->processable->relation_norestriction('Build-Depends-All');
+ my $build_regular = $self->processable->relation('Build-Depends');
+ my $build_indep = $self->processable->relation('Build-Depends-Indep');
+
+ # no need to look for items we have
+ delete %GLOBAL_DEPENDS{$_}
+ for grep { $build_regular->satisfies($_) } keys %GLOBAL_DEPENDS;
+ delete %GLOBAL_CLEAN_DEPENDS{$_}
+ for grep { $build_regular->satisfies($_) } keys %GLOBAL_CLEAN_DEPENDS;
+ delete %RULE_CLEAN_DEPENDS{$_}
+ for grep { $build_regular->satisfies($_) } keys %RULE_CLEAN_DEPENDS;
+
+ my @needed;
+ my @needed_clean;
+
+ # Scan debian/rules. We would really like to let make do this for
+ # us, but unfortunately there doesn't seem to be a way to get make
+ # to syntax-check and analyze a makefile without running at least
+ # $(shell) commands.
+ #
+ # We skip some of the rule analysis if debian/rules includes any
+ # other files, since to chase all includes we'd have to have all
+ # of its build dependencies installed.
+ local $_ = undef;
+
+ my @arch_rules = map { qr/^$_$/ } qw(clean binary-arch build-arch);
+ my @indep_rules = qw(build build-indep binary-indep);
+ my @current_targets;
+ my %rules_per_target;
+ my %debhelper_group;
+ my %seen;
+ my %overridden;
+ my $maybe_skipping;
+ my @conditionals;
+ my %variables;
+ my $includes = 0;
+
+ my $contents = $rules->decoded_utf8;
+ return
+ unless length $contents;
+
+ my @lines = split(/\n/, $contents);
+
+ my $continued = $EMPTY;
+ my $position = 1;
+
+ for my $line (@lines) {
+
+ my $pointer = $rules->pointer($position);
+
+ $self->pointed_hint('debian-rules-is-dh_make-template', $pointer)
+ if $line =~ m/dh_make generated override targets/;
+
+ next
+ if $line =~ /^\s*\#/;
+
+ if (length $continued) {
+ $line = $continued . $line;
+ $continued = $EMPTY;
+ }
+
+ if ($line =~ s/\\$//) {
+ $continued = $line;
+ next;
+ }
+
+ if ($line =~ /^\s*[s-]?include\s+(\S++)/){
+ my $makefile = $1;
+ my $targets = $KNOWN_MAKEFILES->value($makefile);
+ if (defined $targets){
+ for my $target (split /\s*+,\s*+/, $targets){
+ $seen{$target}++ if exists $TAG_FOR_POLICY_TARGET{$target};
+ }
+ } else {
+ $includes = 1;
+ }
+
+ $self->pointed_hint('debian-rules-uses-deprecated-makefile',
+ $pointer, $makefile)
+ if $DEPRECATED_MAKEFILES->recognizes($makefile);
+ }
+
+ # problems occurring only outside targets
+ unless (%seen) {
+
+ # Check for DH_COMPAT settings outside of any rule, which are now
+ # deprecated. It's a bit easier structurally to do this here than in
+ # debhelper.
+ $self->pointed_hint('debian-rules-sets-DH_COMPAT', $pointer)
+ if $line =~ /^\s*(?:export\s+)?DH_COMPAT\s*:?=/;
+
+ $self->pointed_hint('debian-rules-sets-DEB_BUILD_OPTIONS',$pointer)
+ if $line =~ /^\s*(?:export\s+)?DEB_BUILD_OPTIONS\s*:?=/;
+
+ if (
+ $line =~m{^
+ \s*(?:export\s+)?
+ (DEB_(?:HOST|BUILD|TARGET)_(?:ARCH|MULTIARCH|GNU)[A-Z_]*)\s*:?=
+ }x
+ ) {
+ my $variable = $1;
+
+ $self->pointed_hint(
+ 'debian-rules-sets-dpkg-architecture-variable',
+ $pointer, $variable);
+ }
+
+ }
+
+ if ( $line =~ /^\t\s*-(?:\$[\(\{]MAKE[\}\)]|make)\s.*(?:dist)?clean/s
+ || $line
+ =~ /^\t\s*(?:\$[\(\{]MAKE[\}\)]|make)\s(?:.*\s)?-(\w*)i.*(?:dist)?clean/s
+ ) {
+ my $flags = $1 // $EMPTY;
+
+ # Ignore "-C<dir>" (#671537)
+ $self->pointed_hint('debian-rules-ignores-make-clean-error',
+ $pointer)
+ unless $flags =~ /^C/;
+ }
+
+ if ($line
+ =~ m{dh_strip\b.*(--(?:ddeb|dbgsym)-migration=(?:'[^']*'|\S*))}) {
+
+ my $context = $1;
+
+ $self->pointed_hint('debug-symbol-migration-possibly-complete',
+ $pointer, $context);
+ }
+
+ $self->pointed_hint('debian-rules-passes-version-info-to-dh_shlibdeps',
+ $pointer)
+ if $line =~ m{dh_shlibdeps\b.*(?:--version-info|-V)\b};
+
+ $self->pointed_hint('debian-rules-updates-control-automatically',
+ $pointer)
+ if $line =~ m{^\s*DEB_AUTO_UPDATE_DEBIAN_CONTROL\s*=\s*yes};
+
+ $self->pointed_hint('debian-rules-uses-deb-build-opts', $pointer)
+ if $line =~ m{\$[\(\{]DEB_BUILD_OPTS[\)\}]};
+
+ if ($line =~ m{^\s*DH_EXTRA_ADDONS\s*=\s*(.*)$}) {
+
+ my $context = $1;
+
+ $self->pointed_hint('debian-rules-should-not-use-DH_EXTRA_ADDONS',
+ $pointer, $context);
+ }
+
+ $self->pointed_hint('debian-rules-uses-wrong-environment-variable',
+ $pointer)
+ if $line =~ m{\bDEB_[^_ \t]+FLAGS_(?:SET|APPEND)\b};
+
+ $self->pointed_hint('debian-rules-calls-pwd', $pointer)
+ if $line =~ m{\$[\(\{]PWD[\)\}]};
+
+ $self->pointed_hint(
+ 'debian-rules-should-not-use-sanitize-all-buildflag',$pointer)
+ if $line
+ =~ m{^\s*(?:export\s+)?DEB_BUILD_MAINT_OPTIONS\s*:?=.*\bsanitize=\+all\b};
+
+ $self->pointed_hint('debian-rules-uses-special-shell-variable',
+ $pointer)
+ if $line =~ m{\$[\(\{]_[\)\}]};
+
+ if ($line =~ m{(dh_builddeb\b.*--.*-[zZS].*)$}) {
+
+ my $context = $1;
+
+ $self->pointed_hint('custom-compression-in-debian-rules',
+ $pointer, $context);
+ }
+
+ if ($line =~ m{(py3versions\s+([\w\-\s]*--installed|-\w*i\w*))}) {
+
+ my $context = $1;
+
+ $self->pointed_hint('debian-rules-uses-installed-python-versions',
+ $pointer, $context);
+ }
+
+ $self->pointed_hint('debian-rules-uses-as-needed-linker-flag',$pointer)
+ if $line =~ /--as-needed/ && $line !~ /--no-as-needed/;
+
+ if ($line =~ /(py3versions\s+([\w\-\s]*--supported|-\w*s\w*))/) {
+
+ my $context = $1;
+
+ $self->pointed_hint(
+'debian-rules-uses-supported-python-versions-without-python-all-build-depends',
+ $pointer,
+ $context
+ )unless $build_all_norestriction->satisfies($PYTHON3_ALL_DEPEND);
+ }
+
+ # General assignment - save the variable
+ if ($line =~ /^\s*(?:\S+\s+)*?(\S+)\s*[:\?\+]?=\s*(.*+)?$/s) {
+ # This is far too simple from a theoretical PoV, but should do
+ # rather well.
+ my ($var, $value) = ($1, $2);
+ $variables{$var} = $value;
+
+ $self->pointed_hint('unnecessary-source-date-epoch-assignment',
+ $pointer)
+ if $var eq 'SOURCE_DATE_EPOCH'
+ && !$build_all->satisfies(
+ 'dpkg-dev:any (>= 1.18.8) | debhelper:any (>= 10.10)');
+ }
+
+ # Keep track of whether this portion of debian/rules may be optional
+ if ($line =~ /^ifn?(?:eq|def)\s(.*)/) {
+ push(@conditionals, $1);
+ $maybe_skipping++;
+
+ } elsif ($line =~ /^endif\s/) {
+ $maybe_skipping--;
+ }
+
+ unless ($maybe_skipping) {
+
+ for my $prerequisite (keys %GLOBAL_DEPENDS) {
+
+ my @patterns = @{ $GLOBAL_DEPENDS{$prerequisite} };
+
+ push(@needed, $prerequisite)
+ if any { $line =~ $_ } @patterns;
+ }
+
+ for my $prerequisite (keys %GLOBAL_CLEAN_DEPENDS) {
+
+ my @patterns = @{ $GLOBAL_CLEAN_DEPENDS{$prerequisite} };
+
+ if (any { $line =~ $_ } @patterns) {
+
+ push(@needed, $prerequisite);
+ push(@needed_clean, $prerequisite);
+ }
+ }
+ }
+
+ # Listing a rule as a dependency of .PHONY is sufficient to make it
+ # present for the purposes of GNU make and therefore the Policy
+ # requirement.
+ if ($line =~ /^(?:[^:]+\s)?\.PHONY(?:\s[^:]+)?:(.+)/s) {
+
+ my @targets = split($SPACE, $1);
+ for my $target (@targets) {
+ # Is it $(VAR) ?
+ if ($target =~ /^\$[\(\{]([^\)\}]++)[\)\}]$/) {
+ my $name = $1;
+ my $val = $variables{$name};
+ if ($val) {
+ # we think we know what it will expand to - note
+ # we ought to "delay" it was a "=" variable rather
+ # than ":=" or "+=".
+
+ # discards empty elements at end, effectively trimming right
+ for (split(/\s+/, $val)) {
+ $seen{$target}++
+ if exists $TAG_FOR_POLICY_TARGET{$target};
+ }
+ last;
+ }
+ # We don't know, so just mark the target as seen.
+ }
+ $seen{$target}++
+ if exists $TAG_FOR_POLICY_TARGET{$target};
+ }
+
+ #.PHONY implies the rest will not match
+ next;
+ }
+
+ if ( !$includes
+ && $line
+ =~ /dpkg-parsechangelog.*(?:Source|Version|Date|Timestamp)/s) {
+
+ $self->pointed_hint('debian-rules-parses-dpkg-parsechangelog',
+ $pointer);
+ }
+
+ if ($line !~ /^ifn?(?:eq|def)\s/ && $line =~ /^([^\s:][^:]*):+(.*)/s) {
+ my ($target_names, $target_dependencies) = ($1, $2);
+ @current_targets = split $SPACE, $target_names;
+
+ my @quoted = map { quotemeta } split($SPACE, $target_dependencies);
+ s/\\\$\\\([^\):]+\\:([^=]+)\\=([^\)]+)\1\\\)/$2.*/g for @quoted;
+
+ my @depends = map { qr/^$_$/ } @quoted;
+
+ for my $target (@current_targets) {
+ $overridden{$1} = $position if $target =~ m/override_(.+)/;
+ if ($target =~ /%/) {
+ my $pattern = quotemeta $target;
+ $pattern =~ s/\\%/.*/g;
+ for my $rulebypolicy (keys %TAG_FOR_POLICY_TARGET) {
+ $seen{$rulebypolicy}++ if $rulebypolicy =~ m/$pattern/;
+ }
+ } else {
+ # Is it $(VAR) ?
+ if ($target =~ m/^\$[\(\{]([^\)\}]++)[\)\}]$/) {
+ my $name = $1;
+ my $val = $variables{$name};
+ if ($val) {
+ # we think we know what it will expand to - note
+ # we ought to "delay" it was a "=" variable rather
+ # than ":=" or "+=".
+ local $_ = undef;
+
+ # discards empty elements at end, effectively trimming right
+ for (split(/\s+/, $val)) {
+ $seen{$_}++
+ if exists $TAG_FOR_POLICY_TARGET{$_};
+ }
+ last;
+ }
+ # We don't know, so just mark the target as seen.
+ }
+ $seen{$target}++ if exists $TAG_FOR_POLICY_TARGET{$target};
+ }
+ if (any { $target =~ /$_/ } @arch_rules) {
+ push(@arch_rules, @depends);
+ }
+ }
+ undef %debhelper_group;
+
+ } elsif ($line =~ /^define /) {
+ # We don't want to think the body of the define is part of
+ # the previous rule or we'll get false positives on tags
+ # like binary-arch-rules-but-pkg-is-arch-indep. Treat a
+ # define as the end of the current rule, although that
+ # isn't very accurate either.
+ @current_targets = ();
+
+ } else {
+ # If we have non-empty, non-comment lines, store them for
+ # all current targets and check whether debhelper programs
+ # are called in a reasonable order.
+ if ($line =~ /^\s+[^\#]/) {
+ my ($arch, $indep) = (0, 0);
+ for my $target (@current_targets) {
+ $rules_per_target{$target} ||= [];
+ push(@{$rules_per_target{$target}}, $line);
+
+ $arch = 1
+ if any { $target =~ /$_/ } @arch_rules;
+
+ $indep = 1
+ if any { $target eq $_ } @indep_rules;
+
+ $indep = 1
+ if $target eq $PERCENT;
+
+ $indep = 1
+ if $target =~ /^override_/;
+ }
+
+ if (!$maybe_skipping && ($arch || $indep)) {
+
+ for my $prerequisite (keys %RULE_CLEAN_DEPENDS) {
+
+ my @patterns = @{ $RULE_CLEAN_DEPENDS{$prerequisite} };
+
+ if (any { $line =~ $_ } @patterns) {
+
+ push(@needed, $prerequisite);
+ push(@needed_clean, $prerequisite)
+ if $arch;
+ }
+ }
+ }
+
+ if ($line =~ /^\s+(dh_\S+)\b/ && $debhelper_order{$1}) {
+ my $command = $1;
+ my ($package) = ($line =~ /\s(?:-p|--package=)(\S+)/);
+ $package ||= $EMPTY;
+ my $group = $debhelper_order{$command};
+ $debhelper_group{$package} ||= 0;
+
+ if ($group < $debhelper_group{$package}) {
+
+ $self->pointed_hint(
+ 'debian-rules-calls-debhelper-in-odd-order',
+ $pointer, $command);
+
+ } else {
+ $debhelper_group{$package} = $group;
+ }
+ }
+ }
+ }
+
+ } continue {
+ ++$position;
+ }
+
+ my @missing_targets;
+ @missing_targets = grep { !$seen{$_} } keys %TAG_FOR_POLICY_TARGET
+ unless $includes;
+
+ $self->pointed_hint($TAG_FOR_POLICY_TARGET{$_}, $rules->pointer, $_)
+ for @missing_targets;
+
+ # Make sure we have no content for binary-arch if we are arch-indep:
+ $rules_per_target{'binary-arch'} ||= [];
+ if ($architecture eq 'all' && scalar @{$rules_per_target{'binary-arch'}}) {
+
+ my $nonempty = 0;
+ for my $rule (@{$rules_per_target{'binary-arch'}}) {
+ # dh binary-arch is actually a no-op if there is no
+ # Architecture: any package in the control file
+ $nonempty = 1
+ unless $rule =~ /^\s*dh\s+(?:binary-arch|\$\@)/;
+ }
+
+ $self->pointed_hint('binary-arch-rules-but-pkg-is-arch-indep',
+ $rules->pointer)
+ if $nonempty;
+ }
+
+ for my $cmd (qw(dh_clean dh_fixperms)) {
+ for my $suffix ($EMPTY, '-indep', '-arch') {
+
+ my $memorized_position = $overridden{"$cmd$suffix"};
+ next
+ unless defined $memorized_position;
+
+ $self->pointed_hint(
+ "override_$cmd-does-not-call-$cmd",
+ $rules->pointer($memorized_position)
+ )
+ if none { m/^\t\s*-?($cmd\b|\$\(overridden_command\))/ }
+ @{$rules_per_target{"override_$cmd$suffix"}};
+ }
+ }
+
+ if (my $memorized_position = $overridden{'dh_auto_test'}) {
+
+ my @rules = grep {
+ !m{^\t\s*[\:\[]}
+ && !m{^\s*$}
+ && !m{\bdh_auto_test\b}
+ && !
+m{^\t\s*[-@]?(?:(?:/usr)?/bin/)?(?:cp|chmod|echo|ln|mv|mkdir|rm|test|true)}
+ } @{$rules_per_target{'override_dh_auto_test'}};
+
+ $self->pointed_hint(
+ 'override_dh_auto_test-does-not-check-DEB_BUILD_OPTIONS',
+ $rules->pointer($memorized_position))
+ if @rules and none { m/(DEB_BUILD_OPTIONS|nocheck)/ } @conditionals;
+ }
+
+ $self->pointed_hint(
+ 'debian-rules-contains-unnecessary-get-orig-source-target',
+ $rules->pointer)
+ if any { m/^\s+uscan\b/ } @{$rules_per_target{'get-orig-source'}};
+
+ my @clean_in_indep
+ = grep { $build_indep->satisfies($_) } uniq @needed_clean;
+ $self->pointed_hint(
+ 'missing-build-depends-for-clean-target-in-debian-rules',
+ $rules->pointer, "(does not satisfy $_)")
+ for @clean_in_indep;
+
+ # another check complains when debhelper is missing from d/rules
+ my $combined_lc = List::Compare->new(\@needed, ['debhelper:any']);
+
+ my @still_missing
+ = grep { !$build_all_norestriction->satisfies($_) }
+ $combined_lc->get_Lonly;
+
+ $self->pointed_hint('rules-require-build-prerequisite',
+ $rules->pointer, "(does not satisfy $_)")
+ for @still_missing;
+
+ $self->pointed_hint('debian-rules-should-not-set-CFLAGS-from-noopt',
+ $rules->pointer)
+ if $contents
+ =~ m{^ ifn?eq \s+ [(] , \$ [(] findstring \s+ noopt , \$ [(] DEB_BUILD_OPTIONS [)] [)] [)] \n+
+ \t+ CFLAGS \s+ \+ = \s+ -O[02] \n+
+ else \n+
+ \t+ CFLAGS \s+ \+ = \s+ -O[02] \n+
+ endif $}xsm;
+
+ return;
+}
+
+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/Lintian/Check/Debian/Rules/DhSequencer.pm b/lib/Lintian/Check/Debian/Rules/DhSequencer.pm
new file mode 100644
index 0000000..bc2b239
--- /dev/null
+++ b/lib/Lintian/Check/Debian/Rules/DhSequencer.pm
@@ -0,0 +1,65 @@
+# debian/rules/dh-sequencer -- lintian check script -*- perl -*-
+
+# Copyright (C) 2019 Felix Lechner
+# Copyright (C) 2020 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 Lintian::Check::Debian::Rules::DhSequencer;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Moo;
+use namespace::clean;
+
+with 'Lintian::Check';
+
+sub visit_patched_files {
+ my ($self, $item) = @_;
+
+ return
+ unless $item->name eq 'debian/rules';
+
+ my $bytes = $item->bytes;
+
+ # strip comments (see #960485)
+ $bytes =~ s/^\h#.*\R?//mg;
+
+ my $plain = qr/\$\@/;
+ my $curly = qr/\$\{\@\}/;
+ my $asterisk = qr/\$\*/;
+ my $parentheses = qr/\$\(\@\)/;
+ my $rule_altern = qr/(?:$plain|$curly|$asterisk|$parentheses)/;
+ my $rule_target = qr/(?:$rule_altern|'$rule_altern'|"$rule_altern")/;
+
+ $self->pointed_hint('no-dh-sequencer', $item->pointer)
+ unless $bytes =~ /^\t+(?:[\+@-])?(?:[^=]+=\S+ )?dh[ \t]+$rule_target/m
+ || $bytes =~ m{^\s*include\s+/usr/share/cdbs/1/class/hlibrary.mk\s*$}m
+ || $bytes =~ m{\bDEB_CABAL_PACKAGE\b};
+
+ return;
+}
+
+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/Lintian/Check/Debian/Shlibs.pm b/lib/Lintian/Check/Debian/Shlibs.pm
new file mode 100644
index 0000000..8e755d9
--- /dev/null
+++ b/lib/Lintian/Check/Debian/Shlibs.pm
@@ -0,0 +1,656 @@
+# debian/shlibs -- lintian check script -*- perl -*-
+
+# Copyright (C) 1998 Christian Schwarz
+# Copyright (C) 2018-2019 Chris Lamb <lamby@debian.org>
+# Copyright (C) 2021 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 Lintian::Check::Debian::Shlibs;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Const::Fast;
+use File::Basename;
+use List::Compare;
+use List::SomeUtils qw(any none uniq);
+
+use Moo;
+use namespace::clean;
+
+with 'Lintian::Check';
+
+const my $EMPTY => q{};
+const my $SPACE => q{ };
+const my $SLASH => q{/};
+const my $EQUALS => q{=};
+const my $LEFT_PARENTHESIS => q{(};
+const my $RIGHT_PARENTHESIS => q{)};
+
+my @known_meta_labels = qw{
+ Build-Depends-Package
+ Build-Depends-Packages
+ Ignore-Blacklist-Groups
+};
+
+has soname_by_filename => (
+ is => 'rw',
+ lazy => 1,
+ default => sub {
+ my ($self) = @_;
+
+ my %soname_by_filename;
+ for my $item (@{$self->processable->installed->sorted_list}) {
+
+ $soname_by_filename{$item->name}= $item->elf->{SONAME}[0]
+ if exists $item->elf->{SONAME};
+ }
+
+ return \%soname_by_filename;
+ }
+);
+
+has shlibs_positions_by_pretty_soname => (is => 'rw', default => sub { {} });
+has symbols_positions_by_soname => (is => 'rw', default => sub { {} });
+
+sub installable {
+ my ($self) = @_;
+
+ $self->check_shlibs_file;
+ $self->check_symbols_file;
+
+ my @pretty_sonames_from_shlibs
+ = keys %{$self->shlibs_positions_by_pretty_soname};
+ my @pretty_sonames_from_symbols
+ = map { human_soname($_) } keys %{$self->symbols_positions_by_soname};
+
+ # Compare the contents of the shlibs and symbols control files, but exclude
+ # from this check shared libraries whose SONAMEs has no version. Those can
+ # only be represented in symbols files and aren't expected in shlibs files.
+ my $extra_lc = List::Compare->new(\@pretty_sonames_from_symbols,
+ \@pretty_sonames_from_shlibs);
+
+ if (%{$self->shlibs_positions_by_pretty_soname}) {
+
+ my @versioned = grep { m{ } } $extra_lc->get_Lonly;
+
+ $self->hint('symbols-for-undeclared-shared-library', $_)for @versioned;
+ }
+
+ return;
+}
+
+sub check_shlibs_file {
+ my ($self) = @_;
+
+ my @ldconfig_folders = @{$self->data->architectures->ldconfig_folders};
+
+ # Libraries with no version information can't be represented by
+ # the shlibs format (but can be represented by symbols). We want
+ # to warn about them if they appear in public directories. If
+ # they're in private directories, assume they're plugins or
+ # private libraries and are safe.
+ my @unversioned_libraries;
+ for my $file_name (keys %{$self->soname_by_filename}) {
+
+ my $pretty_soname
+ = human_soname($self->soname_by_filename->{$file_name});
+ next
+ if $pretty_soname =~ m{ };
+
+ push(@unversioned_libraries, $file_name);
+ $self->hint('shared-library-lacks-version', $file_name, $pretty_soname)
+ if any { (dirname($file_name) . $SLASH) eq $_ } @ldconfig_folders;
+ }
+
+ my $versioned_lc = List::Compare->new([keys %{$self->soname_by_filename}],
+ \@unversioned_libraries);
+ my @versioned_libraries = $versioned_lc->get_Lonly;
+
+ # 4th step: check shlibs control file
+ # $package_version may be undef in very broken packages
+ my $shlibs_file = $self->processable->control->lookup('shlibs');
+ $shlibs_file = undef
+ if defined $shlibs_file && !$shlibs_file->is_file;
+
+ # no shared libraries included in package, thus shlibs control
+ # file should not be present
+ $self->pointed_hint('empty-shlibs', $shlibs_file->pointer)
+ if defined $shlibs_file && !@versioned_libraries;
+
+ # shared libraries included, thus shlibs control file has to exist
+ for my $file_name (@versioned_libraries) {
+
+ # only public shared libraries
+ $self->hint('no-shlibs', $file_name)
+ if (any { (dirname($file_name) . $SLASH) eq $_ } @ldconfig_folders)
+ && !defined $shlibs_file
+ && $self->processable->type ne 'udeb'
+ && !is_nss_plugin($file_name);
+ }
+
+ if (@versioned_libraries && defined $shlibs_file) {
+
+ my @shlibs_prerequisites;
+
+ my @lines = split(/\n/, $shlibs_file->decoded_utf8);
+
+ my $position = 1;
+ for my $line (@lines) {
+
+ next
+ if $line =~ m{^ \s* $}x
+ || $line =~ m{^ [#] }x;
+
+ # We exclude udebs from the checks for correct shared library
+ # dependencies, since packages may contain dependencies on
+ # other udeb packages.
+
+ my $udeb = $EMPTY;
+ $udeb = 'udeb: '
+ if $line =~ s/^udeb:\s+//;
+
+ my ($name, $version, @prerequisites) = split($SPACE, $line);
+ my $pretty_soname = "$udeb$name $version";
+
+ $self->shlibs_positions_by_pretty_soname->{$pretty_soname} //= [];
+ push(
+ @{$self->shlibs_positions_by_pretty_soname->{$pretty_soname}},
+ $position
+ );
+
+ push(@shlibs_prerequisites, join($SPACE, @prerequisites))
+ unless $udeb;
+
+ } continue {
+ ++$position;
+ }
+
+ my @duplicate_pretty_sonames
+ = grep { @{$self->shlibs_positions_by_pretty_soname->{$_}} > 1 }
+ keys %{$self->shlibs_positions_by_pretty_soname};
+
+ for my $pretty_soname (@duplicate_pretty_sonames) {
+
+ my $indicator
+ = $LEFT_PARENTHESIS . 'lines'
+ . $SPACE
+ . join($SPACE,
+ sort { $a <=> $b }
+ @{$self->shlibs_positions_by_pretty_soname->{$pretty_soname}}
+ ). $RIGHT_PARENTHESIS;
+
+ $self->pointed_hint('duplicate-in-shlibs', $shlibs_file->pointer,
+ $indicator,$pretty_soname);
+ }
+
+ my @used_pretty_sonames;
+ for my $file_name (@versioned_libraries) {
+
+ my $pretty_soname
+ = human_soname($self->soname_by_filename->{$file_name});
+
+ push(@used_pretty_sonames, $pretty_soname);
+ push(@used_pretty_sonames, "udeb: $pretty_soname");
+
+ # only public shared libraries
+ $self->pointed_hint('ships-undeclared-shared-library',
+ $shlibs_file->pointer,$pretty_soname, 'for', $file_name)
+ if (any { (dirname($file_name) . $SLASH) eq $_ }
+ @ldconfig_folders)
+ && !@{$self->shlibs_positions_by_pretty_soname->{$pretty_soname}
+ // []}
+ && !is_nss_plugin($file_name);
+ }
+
+ my $unused_lc
+ = List::Compare->new(
+ [keys %{$self->shlibs_positions_by_pretty_soname}],
+ \@used_pretty_sonames);
+
+ $self->pointed_hint('shared-library-not-shipped',
+ $shlibs_file->pointer, $_)
+ for $unused_lc->get_Lonly;
+
+ my $fields = $self->processable->fields;
+
+ # Check that all of the packages listed as dependencies in
+ # the shlibs file are satisfied by the current package or
+ # its Provides. Normally, packages should only declare
+ # dependencies in their shlibs that they themselves can
+ # satisfy.
+ my $provides = $self->processable->name;
+ $provides
+ .= $LEFT_PARENTHESIS
+ . $EQUALS
+ . $SPACE
+ . $fields->value('Version')
+ . $RIGHT_PARENTHESIS
+ if $fields->declares('Version');
+
+ $provides
+ = $self->processable->relation('Provides')->logical_and($provides);
+
+ for my $prerequisite (uniq @shlibs_prerequisites) {
+
+ $self->pointed_hint('distant-prerequisite-in-shlibs',
+ $shlibs_file->pointer, $prerequisite)
+ unless $provides->satisfies($prerequisite);
+
+ $self->pointed_hint('outdated-relation-in-shlibs',
+ $shlibs_file->pointer, $prerequisite)
+ if $prerequisite =~ m/\(\s*[><](?![<>=])\s*/;
+ }
+ }
+
+ return;
+}
+
+sub check_symbols_file {
+ my ($self) = @_;
+
+ my @ldconfig_folders = @{$self->data->architectures->ldconfig_folders};
+ my @shared_libraries = keys %{$self->soname_by_filename};
+
+ my $fields = $self->processable->fields;
+ my $symbols_file = $self->processable->control->lookup('symbols');
+
+ if (!defined $symbols_file
+ && $self->processable->type ne 'udeb') {
+
+ for my $file_name (@shared_libraries){
+
+ my $item = $self->processable->installed->lookup($file_name);
+ next
+ unless defined $item;
+
+ my @symbols
+ = grep { $_->section eq '.text' || $_->section eq 'UND' }
+ @{$item->elf->{SYMBOLS} // []};
+
+ # only public shared libraries
+ # Skip Objective C libraries as instance/class methods do not
+ # appear in the symbol table
+ $self->hint('no-symbols-control-file', $file_name)
+ if (any { (dirname($file_name) . $SLASH) eq $_ }
+ @ldconfig_folders)
+ && (none { $_->name =~ m/^__objc_/ } @symbols)
+ && !is_nss_plugin($file_name);
+ }
+ }
+
+ return
+ unless defined $symbols_file;
+
+ # no shared libraries included in package, thus symbols
+ # control file should not be present
+ $self->pointed_hint('empty-shared-library-symbols', $symbols_file->pointer)
+ unless @shared_libraries;
+
+ # Assume the version to be a non-native version to avoid
+ # uninitialization warnings later.
+ my $package_version = $fields->value('Version') || '0-1';
+
+ my $package_version_wo_rev = $package_version;
+ $package_version_wo_rev =~ s/^ (.+) - [^-]+ $/$1/x;
+
+ my @sonames;
+ my %symbols_by_soname;
+ my %full_version_symbols_by_soname;
+ my %debian_revision_symbols_by_soname;
+ my %prerequisites_by_soname;
+ my %positions_by_soname_and_meta_label;
+ my @syntax_errors;
+ my $template_count = 0;
+
+ my @lines = split(/\n/, $symbols_file->decoded_utf8);
+
+ my $current_soname = $EMPTY;
+ my $position = 1;
+ for my $line (@lines) {
+
+ next
+ if $line =~ m{^ \s* $}x
+ || $line =~ m{^ [#] }x;
+
+ # soname, main dependency template
+ if ($line
+ =~ m{^ ([^\s|*]\S+) \s\S+\s* (?: [(] \S+\s+\S+ [)] | [#]MINVER[#] )? }x
+ ){
+
+ $current_soname = $1;
+ push(@sonames, $current_soname);
+
+ $line =~ s/^\Q$current_soname\E\s*//;
+
+ $self->symbols_positions_by_soname->{$current_soname} //= [];
+ push(
+ @{$self->symbols_positions_by_soname->{$current_soname}},
+ $position
+ );
+
+ for my $conjunctive (split(m{ \s* , \s* }x, $line)) {
+ for my $disjunctive (split(m{ \s* [|] \s* }x, $conjunctive)){
+
+ $disjunctive
+ =~ m{^ (\S+) ( \s* (?: [(] \S+\s+\S+ [)] | [#]MINVER[#]))? $}x;
+
+ my $package = $1;
+ my $version = $2 || $EMPTY;
+
+ if (length $package) {
+ $prerequisites_by_soname{$current_soname} //= [];
+ push(
+ @{$prerequisites_by_soname{$current_soname}},
+ $package . $version
+ );
+
+ } else {
+ push(@syntax_errors, $position);
+ }
+ }
+ }
+
+ $template_count = 0;
+
+ next;
+ }
+
+ # alternative dependency template
+ if ($line
+ =~ m{^ [|] \s+\S+\s* (?: [(] \S+\s+\S+ [)] | [#]MINVER[#] )? }x) {
+
+ my $error = 0;
+
+ if (%{$positions_by_soname_and_meta_label{$current_soname} // {} }
+ || !length $current_soname) {
+
+ push(@syntax_errors, $position);
+ $error = 1;
+ }
+
+ $line =~ s{^ [|] \s* }{}x;
+
+ for my $conjunctive (split(m{ \s* , \s* }x, $line)) {
+ for my $disjunctive (split(m{ \s* [|] \s* }x, $conjunctive)) {
+
+ $disjunctive
+ =~ m{^ (\S+) ( \s* (?: [(] \S+ \s+ \S+ [)] | [#]MINVER[#] ) )? $}x;
+
+ my $package = $1;
+ my $version = $2 || $EMPTY;
+
+ if (length $package) {
+ $prerequisites_by_soname{$current_soname} //= [];
+ push(
+ @{$prerequisites_by_soname{$current_soname}},
+ $package . $version
+ );
+
+ } else {
+ push(@syntax_errors, $position)
+ unless $error;
+
+ $error = 1;
+ }
+ }
+ }
+
+ $template_count++ unless $error;
+
+ next;
+ }
+
+ # meta-information
+ if ($line =~ m{^ [*] \s (\S+) : \s \S+ }x) {
+
+ my $meta_label = $1;
+
+ $positions_by_soname_and_meta_label{$current_soname}{$meta_label}
+ //= [];
+ push(
+ @{
+ $positions_by_soname_and_meta_label{$current_soname}
+ {$meta_label}
+ },
+ $position
+ );
+
+ push(@syntax_errors, $position)
+ if !defined $current_soname
+ || @{$symbols_by_soname{$current_soname} // [] };
+
+ next;
+ }
+
+ # Symbol definition
+ if ($line =~ m{^\s+ (\S+) \s (\S+) (?:\s (\S+ (?:\s\S+)? ) )? $}x) {
+
+ my $symbol = $1;
+ my $version = $2;
+ my $selector = $3 // $EMPTY;
+
+ push(@syntax_errors, $position)
+ unless length $current_soname;
+
+ $symbols_by_soname{$current_soname} //= [];
+ push(@{$symbols_by_soname{$current_soname}}, $symbol);
+
+ if ($version eq $package_version && $package_version =~ m{-}) {
+ $full_version_symbols_by_soname{$current_soname} //= [];
+ push(
+ @{$full_version_symbols_by_soname{$current_soname}},
+ $symbol
+ );
+
+ } elsif ($version =~ m{-}
+ && $version !~ m{~$}
+ && $version ne $package_version_wo_rev) {
+
+ $debian_revision_symbols_by_soname{$current_soname} //= [];
+ push(
+ @{$debian_revision_symbols_by_soname{$current_soname}},
+ $symbol
+ );
+ }
+
+ $self->pointed_hint('invalid-template-id-in-symbols-file',
+ $symbols_file->pointer($position),$selector)
+ if length $selector
+ && ($selector !~ m{^ \d+ $}x || $selector > $template_count);
+
+ next;
+ }
+
+ push(@syntax_errors, $position);
+
+ } continue {
+ ++$position;
+ }
+
+ my @duplicate_sonames
+ = grep { @{$self->symbols_positions_by_soname->{$_}} > 1 }
+ keys %{$self->symbols_positions_by_soname};
+
+ for my $soname (@duplicate_sonames) {
+
+ my $indicator
+ = $LEFT_PARENTHESIS . 'lines'
+ . $SPACE
+ . join($SPACE,
+ sort { $a <=> $b }@{$self->symbols_positions_by_soname->{$soname}})
+ . $RIGHT_PARENTHESIS;
+
+ my $pretty_soname = human_soname($soname);
+
+ $self->pointed_hint('duplicate-entry-in-symbols-control-file',
+ $symbols_file->pointer,$indicator,$pretty_soname);
+ }
+
+ $self->pointed_hint('syntax-error-in-symbols-file',
+ $symbols_file->pointer($_))
+ for uniq @syntax_errors;
+
+ # Check that all of the packages listed as dependencies in the symbols
+ # file are satisfied by the current package or its Provides.
+ # Normally, packages should only declare dependencies in their symbols
+ # files that they themselves can satisfy.
+ my $provides = $self->processable->name;
+ $provides
+ .= $LEFT_PARENTHESIS
+ . $EQUALS
+ . $SPACE
+ . $fields->value('Version')
+ . $RIGHT_PARENTHESIS
+ if $fields->declares('Version');
+
+ $provides
+ = $self->processable->relation('Provides')->logical_and($provides);
+
+ for my $soname (uniq @sonames) {
+
+ my @used_meta_labels
+ = keys %{$positions_by_soname_and_meta_label{$soname} // {} };
+
+ my $meta_lc
+ = List::Compare->new(\@used_meta_labels, \@known_meta_labels);
+
+ for my $meta_label ($meta_lc->get_Lonly) {
+
+ $self->pointed_hint(
+ 'unknown-meta-field-in-symbols-file',
+ $symbols_file->pointer($_),
+ $meta_label, "($soname)"
+ )
+ for @{$positions_by_soname_and_meta_label{$soname}{$meta_label}};
+ }
+
+ $self->pointed_hint('symbols-file-missing-build-depends-package-field',
+ $symbols_file->pointer,$soname)
+ if none { $_ eq 'Build-Depends-Package' } @used_meta_labels;
+
+ my @full_version_symbols
+ = @{$full_version_symbols_by_soname{$soname} // [] };
+ if (@full_version_symbols) {
+
+ my @sorted = sort +uniq @full_version_symbols;
+
+ my $context = 'on symbol ' . $sorted[0];
+ $context .= ' and ' . (scalar @sorted - 1) . ' others'
+ if @sorted > 1;
+
+ $self->pointed_hint(
+ 'symbols-file-contains-current-version-with-debian-revision',
+ $symbols_file->pointer,$context, "($soname)");
+ }
+
+ my @debian_revision_symbols
+ = @{$debian_revision_symbols_by_soname{$soname} // [] };
+ if (@debian_revision_symbols) {
+
+ my @sorted = sort +uniq @debian_revision_symbols;
+
+ my $context = 'on symbol ' . $sorted[0];
+ $context .= ' and ' . (scalar @sorted - 1) . ' others'
+ if @sorted > 1;
+
+ $self->pointed_hint('symbols-file-contains-debian-revision',
+ $symbols_file->pointer,$context, "($soname)");
+ }
+
+ # Deduplicate the list of dependencies before warning so that we don't
+ # duplicate warnings.
+ for
+ my $prerequisite (uniq @{$prerequisites_by_soname{$soname} // [] }) {
+
+ $prerequisite =~ s/ [ ] [#] MINVER [#] $//x;
+ $self->pointed_hint('symbols-declares-dependency-on-other-package',
+ $symbols_file->pointer,$prerequisite, "($soname)")
+ unless $provides->satisfies($prerequisite);
+ }
+ }
+
+ my @used_pretty_sonames;
+ for my $filename (@shared_libraries) {
+
+ my $soname = $self->soname_by_filename->{$filename};
+ my $pretty_soname = human_soname($soname);
+
+ push(@used_pretty_sonames, $pretty_soname);
+ push(@used_pretty_sonames, "udeb: $pretty_soname");
+
+ # only public shared libraries
+ $self->pointed_hint('shared-library-symbols-not-tracked',
+ $symbols_file->pointer,$pretty_soname,'for', $filename)
+ if (any { (dirname($filename) . $SLASH) eq $_ }@ldconfig_folders)
+ && !@{$self->symbols_positions_by_soname->{$soname}// [] }
+ && !is_nss_plugin($filename);
+ }
+
+ my @available_pretty_sonames
+ = map { human_soname($_) } keys %{$self->symbols_positions_by_soname};
+
+ my $unused_lc
+ = List::Compare->new(\@available_pretty_sonames,\@used_pretty_sonames);
+
+ $self->pointed_hint('surplus-shared-library-symbols',
+ $symbols_file->pointer, $_)
+ for $unused_lc->get_Lonly;
+
+ return;
+}
+
+# Extract the library name and the version from an SONAME and return them
+# separated by a space. This code should match the split_soname function in
+# dpkg-shlibdeps.
+sub human_soname {
+ my ($string) = @_;
+
+ # libfoo.so.X.X
+ # libfoo-X.X.so
+ if ( $string =~ m{^ (.*) [.]so[.] (.*) $}x
+ || $string =~ m{^ (.*) - (\d.*) [.]so $}x) {
+
+ my $name = $1;
+ my $version = $2;
+
+ return $name . $SPACE . $version;
+ }
+
+ return $string;
+}
+
+# Returns a truth value if the first argument appears to be the path
+# to a libc nss plugin (libnss_<name>.so.$version).
+sub is_nss_plugin {
+ my ($name) = @_;
+
+ return 1
+ if $name =~ m{^ (?:.*/)? libnss_[^.]+ [.]so[.] \d+ $}x;
+
+ return 0;
+}
+
+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/Lintian/Check/Debian/Source/IncludeBinaries.pm b/lib/Lintian/Check/Debian/Source/IncludeBinaries.pm
new file mode 100644
index 0000000..48e8926
--- /dev/null
+++ b/lib/Lintian/Check/Debian/Source/IncludeBinaries.pm
@@ -0,0 +1,77 @@
+# debian/source/include-binaries -- lintian check script -*- perl -*-
+
+# 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 Lintian::Check::Debian::Source::IncludeBinaries;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Path::Tiny;
+
+use Moo;
+use namespace::clean;
+
+with 'Lintian::Check';
+
+sub source {
+ my ($self) = @_;
+
+ my $sourcedir= $self->processable->patched->resolve_path('debian/source/');
+ return
+ unless $sourcedir;
+
+ my $item = $sourcedir->child('include-binaries');
+ return
+ unless $item && $item->is_open_ok;
+
+ my @lines = path($item->unpacked_path)->lines({ chomp => 1 });
+
+ # format described in dpkg-source (1)
+ my $position = 1;
+ for my $line (@lines) {
+
+ next
+ if $line =~ /^\s*$/;
+
+ next
+ if $line =~ /^#/;
+
+ # trim both ends
+ $line =~ s/^\s+|\s+$//g;
+
+ $self->pointed_hint('unused-entry-in-debian-source-include-binaries',
+ $item->pointer($position), $line)
+ unless $self->processable->patched->resolve_path($line);
+
+ } continue {
+ ++$position;
+ }
+
+ return;
+}
+
+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/Lintian/Check/Debian/SourceDir.pm b/lib/Lintian/Check/Debian/SourceDir.pm
new file mode 100644
index 0000000..2fd2ebf
--- /dev/null
+++ b/lib/Lintian/Check/Debian/SourceDir.pm
@@ -0,0 +1,170 @@
+# debian/source directory content -- lintian check script -*- perl -*-
+
+# Copyright (C) 2010 by Raphael Hertzog
+# Copyright (C) 2021 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 Lintian::Check::Debian::SourceDir;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Const::Fast;
+use List::SomeUtils qw(any);
+use Unicode::UTF8 qw(encode_utf8);
+
+use Moo;
+use namespace::clean;
+
+with 'Lintian::Check';
+
+const my $EMPTY => q{};
+const my $SPACE => q{ };
+
+our %KNOWN_FORMATS = map { $_ => 1 }
+ ('1.0', '2.0', '3.0 (quilt)', '3.0 (native)', '3.0 (git)', '3.0 (bzr)');
+
+my %OLDER_FORMATS = map { $_ => 1 }('1.0');
+
+sub source {
+ my ($self) = @_;
+
+ my $processable = $self->processable;
+
+ my $dsrc = $processable->patched->resolve_path('debian/source/');
+ my ($format_file, $git_pfile, $format, $format_extra);
+
+ $format_file = $dsrc->child('format') if $dsrc;
+
+ if ($format_file and $format_file->is_open_ok) {
+
+ open(my $fd, '<', $format_file->unpacked_path)
+ or die encode_utf8('Cannot open ' . $format_file->unpacked_path);
+
+ $format = <$fd>;
+ chomp $format;
+ close($fd);
+ $format_extra = $EMPTY;
+ die encode_utf8("unknown source format $format")
+ unless $KNOWN_FORMATS{$format};
+ } else {
+ $self->hint('missing-debian-source-format');
+ $format = '1.0';
+ $format_extra = 'implicit';
+ }
+ if ($format eq '1.0') {
+ $format_extra .= $SPACE if $format_extra;
+ if (keys %{$processable->diffstat}) {
+ $format_extra .= 'non-native';
+ } else {
+ $format_extra .= 'native';
+ }
+ }
+ my $format_info = $format;
+ $format_info .= " [$format_extra]"
+ if $format_extra;
+ $self->hint('source-format', $format_info);
+
+ $self->hint('older-source-format', $format) if $OLDER_FORMATS{$format};
+
+ return if not $dsrc;
+
+ $git_pfile = $dsrc->child('git-patches');
+
+ if ($git_pfile and $git_pfile->is_open_ok and $git_pfile->size != 0) {
+
+ open(my $git_patches_fd, '<', $git_pfile->unpacked_path)
+ or die encode_utf8('Cannot open ' . $git_pfile->unpacked_path);
+
+ if (any { !/^\s*+#|^\s*+$/} <$git_patches_fd>) {
+ my $dpseries
+ = $processable->patched->resolve_path('debian/patches/series');
+ # gitpkg does not create series as a link, so this is most likely
+ # a traversal attempt.
+ if (not $dpseries or not $dpseries->is_open_ok) {
+
+ $self->pointed_hint('git-patches-not-exported',
+ $git_pfile->pointer);
+
+ } else {
+ open(my $series_fd, '<', $dpseries->unpacked_path)
+ or
+ die encode_utf8('Cannot open ' . $dpseries->unpacked_path);
+
+ my $comment_line = <$series_fd>;
+ my $count = grep { !/^\s*+\#|^\s*+$/ } <$series_fd>;
+
+ $self->pointed_hint('git-patches-not-exported',
+ $dpseries->pointer)
+ unless (
+ $count
+ && ($comment_line
+ =~ /^\s*\#.*quilt-patches-deb-export-hook/)
+ );
+
+ close $series_fd;
+ }
+ }
+ close $git_patches_fd;
+ }
+
+ my $KNOWN_FILES= $self->data->load('debian-source-dir/known-files');
+
+ my @files = grep { !$_->is_dir } $dsrc->children;
+ for my $item (@files) {
+
+ $self->pointed_hint('unknown-file-in-debian-source', $item->pointer)
+ unless $KNOWN_FILES->recognizes($item->basename);
+ }
+
+ my $options = $processable->patched->resolve_path('debian/source/options');
+ if ($options and $options->is_open_ok) {
+
+ open(my $fd, '<', $options->unpacked_path)
+ or die encode_utf8('Cannot open ' . $options->unpacked_path);
+
+ my $position = 1;
+ while (my $line = <$fd>) {
+
+ if ($line =~ /^\s*(compression(?:-level)?\s*=\s+\S+)\n/) {
+
+ my $level = $1;
+
+ $self->pointed_hint(
+ 'custom-compression-in-debian-source-options',
+ $options->pointer($position), $level);
+ }
+
+ } continue {
+ ++$position;
+ }
+
+ close $fd;
+ }
+
+ return;
+}
+
+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/Lintian/Check/Debian/Substvars.pm b/lib/Lintian/Check/Debian/Substvars.pm
new file mode 100644
index 0000000..d612783
--- /dev/null
+++ b/lib/Lintian/Check/Debian/Substvars.pm
@@ -0,0 +1,55 @@
+# Copyright (C) 1998 Christian Schwarz and Richard Braakman
+# Copyright (C) 1999 Joey Hess
+# Copyright (C) 2000 Sean 'Shaleh' Perry
+# Copyright (C) 2002 Josip Rodin
+# Copyright (C) 2007 Russ Allbery
+# Copyright (C) 2013-2018 Bastien ROUCARIES
+# Copyright (C) 2017-2020 Chris Lamb <lamby@debian.org>
+# Copyright (C) 2020-2021 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 Lintian::Check::Debian::Substvars;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Moo;
+use namespace::clean;
+
+with 'Lintian::Check';
+
+sub visit_patched_files {
+ my ($self, $item) = @_;
+
+ return
+ unless $item->is_file;
+
+ $self->pointed_hint('source-contains-debian-substvars', $item->pointer)
+ if $item->name =~ m{^debian/(?:.+\.)?substvars$}s;
+
+ return;
+}
+
+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/Lintian/Check/Debian/Symbols.pm b/lib/Lintian/Check/Debian/Symbols.pm
new file mode 100644
index 0000000..42b36fe
--- /dev/null
+++ b/lib/Lintian/Check/Debian/Symbols.pm
@@ -0,0 +1,83 @@
+# debian/symbols -- lintian check script -*- perl -*-
+#
+# Copyright (C) 2019-2021 Felix Lechner
+#
+# Parts of the code were taken from the old check script, which
+# was Copyright (C) 1998 Richard Braakman (also licensed under the
+# GPL 2 or higher)
+#
+# 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 Lintian::Check::Debian::Symbols;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Unicode::UTF8 qw(encode_utf8);
+
+use Moo;
+use namespace::clean;
+
+with 'Lintian::Check';
+
+sub visit_patched_files {
+ my ($self, $item) = @_;
+
+ # look at symbols files
+ return
+ unless $item->name =~ qr{^ debian/ (?:.+[.]) symbols $}x;
+
+ return
+ unless $item->is_file && $item->is_open_ok;
+
+ open(my $fd, '<', $item->unpacked_path)
+ or die encode_utf8('Cannot open ' . $item->unpacked_path);
+
+ my $position = 1;
+ while (my $line = <$fd>) {
+
+ chop $line;
+ next
+ if $line =~ /^\s*$/
+ || $line =~ /^#/;
+
+ # meta-information
+ if ($line =~ /^\*\s(\S+):\s+(\S+)/) {
+
+ my $field = $1;
+ my $value = $2;
+
+ $self->pointed_hint('package-placeholder-in-symbols-file',
+ $item->pointer($position))
+ if $field eq 'Build-Depends-Package' && $value =~ /#PACKAGE#/;
+ }
+
+ } continue {
+ ++$position;
+ }
+
+ return;
+}
+
+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/Lintian/Check/Debian/TrailingWhitespace.pm b/lib/Lintian/Check/Debian/TrailingWhitespace.pm
new file mode 100644
index 0000000..465fa59
--- /dev/null
+++ b/lib/Lintian/Check/Debian/TrailingWhitespace.pm
@@ -0,0 +1,105 @@
+# debian/trailing-whitespace -- lintian check script -*- perl -*-
+#
+# based on debhelper check,
+# Copyright (C) 1999 Joey Hess
+# Copyright (C) 2000 Sean 'Shaleh' Perry
+# Copyright (C) 2002 Josip Rodin
+# Copyright (C) 2007 Russ Allbery
+# Copyright (C) 2013-2018 Bastien ROUCARIES
+# Copyright (C) 2017-2020 Chris Lamb <lamby@debian.org>
+# 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 Lintian::Check::Debian::TrailingWhitespace;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Const::Fast;
+
+use Moo;
+use namespace::clean;
+
+with 'Lintian::Check';
+
+const my $KEEP_EMPTY_FIELDS => -1;
+const my $LAST_ITEM => -1;
+
+# list of files to check for a trailing whitespace characters
+my %PROHIBITED_TRAILS = (
+ 'debian/changelog' => qr{\s+$},
+ 'debian/control' => qr{\s+$},
+ # allow trailing tabs in make
+ 'debian/rules' => qr{[ ]+$},
+);
+
+sub visit_patched_files {
+ my ($self, $item) = @_;
+
+ return
+ unless exists $PROHIBITED_TRAILS{$item->name};
+
+ return
+ unless $item->is_valid_utf8;
+
+ my $contents = $item->decoded_utf8;
+ my @lines = split(/\n/, $contents, $KEEP_EMPTY_FIELDS);
+
+ my @trailing_whitespace;
+ my @empty_at_end;
+
+ my $position = 1;
+ for my $line (@lines) {
+
+ push(@trailing_whitespace, $position)
+ if $line =~ $PROHIBITED_TRAILS{$item->name};
+
+ # keeps track of any empty lines at the end
+ if (length $line) {
+ @empty_at_end = ();
+ } else {
+ push(@empty_at_end, $position);
+ }
+
+ } continue {
+ ++$position;
+ }
+
+ # require a newline at end and remove it
+ if (scalar @empty_at_end && $empty_at_end[$LAST_ITEM] == scalar @lines){
+ pop @empty_at_end;
+ } else {
+ $self->pointed_hint('no-newline-at-end', $item->pointer);
+ }
+
+ push(@trailing_whitespace, @empty_at_end);
+
+ $self->pointed_hint('trailing-whitespace', $item->pointer($_))
+ for @trailing_whitespace;
+
+ return;
+}
+
+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/Lintian/Check/Debian/Upstream/Metadata.pm b/lib/Lintian/Check/Debian/Upstream/Metadata.pm
new file mode 100644
index 0000000..410733a
--- /dev/null
+++ b/lib/Lintian/Check/Debian/Upstream/Metadata.pm
@@ -0,0 +1,191 @@
+# debian/upstream/metadata -- lintian check script -*- perl -*-
+
+# Copyright (C) 2016 Petter Reinholdtsen
+# Copyright (C) 2020 Chris Lamb <lamby@debian.org>
+# Copyright (C) 2021 Jelmer Vernooij
+#
+# 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 Lintian::Check::Debian::Upstream::Metadata;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Const::Fast;
+use List::Compare;
+use List::Util qw(none);
+use Syntax::Keyword::Try;
+use YAML::XS;
+
+# default changed to false in 0.81; enable then in .perlcriticrc
+$YAML::XS::LoadBlessed = 0;
+
+use Moo;
+use namespace::clean;
+
+with 'Lintian::Check';
+
+const my $EMPTY => q{};
+
+# Need 0.69 for $LoadBlessed (#861958)
+const my $HAS_LOAD_BLESSED => 0.69;
+
+# taken from https://wiki.debian.org/UpstreamMetadata
+my @known_fields = qw(
+ Archive
+ ASCL-Id
+ Bug-Database
+ Bug-Submit
+ Cite-As
+ Changelog
+ CPE
+ Documentation
+ Donation
+ FAQ
+ Funding
+ Gallery
+ Other-References
+ Reference
+ Registration
+ Registry
+ Repository
+ Repository-Browse
+ Screenshots
+ Security-Contact
+ Webservice
+);
+
+# tolerated for packages not using DEP-5 copyright
+my @tolerated_fields = qw(
+ Name
+ Contact
+);
+
+sub source {
+ my ($self) = @_;
+
+ my $item
+ = $self->processable->patched->resolve_path('debian/upstream/metadata');
+
+ if ($self->processable->native) {
+
+ $self->pointed_hint('upstream-metadata-in-native-source',
+ $item->pointer)
+ if defined $item;
+ return;
+ }
+
+ unless (defined $item) {
+ $self->hint('upstream-metadata-file-is-missing');
+ return;
+ }
+
+ $self->pointed_hint('upstream-metadata-exists', $item->pointer);
+
+ unless ($item->is_open_ok) {
+ $self->pointed_hint('upstream-metadata-is-not-a-file', $item->pointer);
+ return;
+ }
+
+ return
+ if $YAML::XS::VERSION < $HAS_LOAD_BLESSED;
+
+ my $yaml;
+ try {
+ $yaml = YAML::XS::LoadFile($item->unpacked_path);
+
+ die
+ unless defined $yaml;
+
+ } catch {
+
+ my $message = $@;
+ my ($reason, $document, $line, $column)= (
+ $message =~ m{
+ \AYAML::XS::Load\sError:\sThe\sproblem:\n
+ \n\s++(.+)\n
+ \n
+ was\sfound\sat\sdocument:\s(\d+),\sline:\s(\d+),\scolumn:\s(\d+)\n}x
+ );
+
+ $message
+ = "$reason (at document $document, line $line, column $column)"
+ if ( length $reason
+ && length $document
+ && length $line
+ && length $document);
+
+ $self->pointed_hint('upstream-metadata-yaml-invalid',
+ $item->pointer, $message);
+
+ return;
+ }
+
+ unless (ref $yaml eq 'HASH') {
+
+ $self->pointed_hint('upstream-metadata-not-yaml-mapping',
+ $item->pointer);
+ return;
+ }
+
+ for my $field (keys %{$yaml}) {
+
+ $self->pointed_hint('upstream-metadata', $item->pointer, $field,
+ $yaml->{$field})
+ if ref($yaml->{$field}) eq $EMPTY;
+ }
+
+ my $lc
+ = List::Compare->new([keys %{$yaml}],[@known_fields, @tolerated_fields]);
+ my @invalid_fields = $lc->get_Lonly;
+
+ $self->pointed_hint('upstream-metadata-field-unknown', $item->pointer, $_)
+ for @invalid_fields;
+
+ $self->pointed_hint('upstream-metadata-missing-repository', $item->pointer)
+ if none { defined $yaml->{$_} } qw(Repository Repository-Browse);
+
+ $self->pointed_hint('upstream-metadata-missing-bug-tracking',
+ $item->pointer)
+ if none { defined $yaml->{$_} } qw(Bug-Database Bug-Submit);
+
+ return;
+}
+
+sub visit_patched_files {
+ my ($self, $item) = @_;
+
+ return
+ unless $item->is_file;
+
+ # here we check old upstream specification
+ # debian/upstream should be a directory
+ $self->pointed_hint('debian-upstream-obsolete-path', $item->pointer)
+ if $item->name eq 'debian/upstream'
+ || $item->name eq 'debian/upstream-metadata.yaml';
+
+ return;
+}
+
+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/Lintian/Check/Debian/Upstream/SigningKey.pm b/lib/Lintian/Check/Debian/Upstream/SigningKey.pm
new file mode 100644
index 0000000..686966c
--- /dev/null
+++ b/lib/Lintian/Check/Debian/Upstream/SigningKey.pm
@@ -0,0 +1,173 @@
+# debian/upstream/signing-key -- lintian check script -*- perl -*-
+
+# Copyright (C) 2018 Felix Lechner
+#
+# This program is free software. It is distributed 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 Lintian::Check::Debian::Upstream::SigningKey;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use File::Temp;
+use List::Util qw(pairs);
+use Unicode::UTF8 qw(decode_utf8);
+
+use Lintian::IPC::Run3 qw(safe_qx);
+
+use Moo;
+use namespace::clean;
+
+with 'Lintian::Check';
+
+sub source {
+ my ($self) = @_;
+
+ my $SIGNING_KEY_FILENAMES
+ = $self->data->load('common/signing-key-filenames');
+
+ # Check all possible locations for signing keys
+ my %key_items;
+ for my $key_name ($SIGNING_KEY_FILENAMES->all) {
+ my $item
+ = $self->processable->patched->resolve_path("debian/$key_name");
+ $key_items{$key_name} = $item
+ if $item && $item->is_file;
+ }
+
+ # Check if more than one signing key is present
+ $self->hint('public-upstream-keys-in-multiple-locations',
+ (sort keys %key_items))
+ if scalar keys %key_items > 1;
+
+ # Go through signing keys and run checks for each
+ for my $key_name (sort keys %key_items) {
+
+ # native packages should not have such keys
+ if ($self->processable->native) {
+
+ $self->pointed_hint('public-upstream-key-in-native-package',
+ $key_items{$key_name}->pointer);
+ next;
+ }
+
+ # set up a temporary directory for gpg
+ my $tempdir = File::Temp->newdir();
+
+ # get keys packets from gpg
+ my @command = (
+ 'gpg', '--homedir',
+ $tempdir, '--batch',
+ '--attribute-fd', '1',
+ '--status-fd', '2',
+ '--with-colons', '--list-packets',
+ $key_items{$key_name}->unpacked_path
+ );
+ my $bytes = safe_qx(@command);
+
+ if ($?) {
+ $self->pointed_hint(
+ 'public-upstream-key-unusable',
+ $key_items{$key_name}->pointer,
+ 'cannot be processed'
+ );
+ next;
+ }
+
+ my $output = decode_utf8($bytes);
+
+ # remove comments
+ $output =~ s/^#[^\n]*$//mg;
+
+ # split into separate keys
+ my @keys = split(/^:public key packet:.*$/m, $output);
+
+ # discard leading information
+ shift @keys;
+
+ unless (scalar @keys) {
+ $self->pointed_hint(
+ 'public-upstream-key-unusable',
+ $key_items{$key_name}->pointer,
+ 'contains no keys'
+ );
+ next;
+ }
+
+ for my $key (@keys) {
+
+ # parse each key into separate packets
+ my ($public_key, @pieces) = split(/^(:.+)$/m, $key);
+ my @packets = pairs @pieces;
+
+ # require at least one packet
+ unless (length $public_key) {
+ $self->pointed_hint(
+ 'public-upstream-key-unusable',
+ $key_items{$key_name}->pointer,
+ 'has no public key'
+ );
+ next;
+ }
+
+ # look for key identifier
+ unless ($public_key =~ qr/^\s*keyid:\s+(\S+)$/m) {
+ $self->pointed_hint(
+ 'public-upstream-key-unusable',
+ $key_items{$key_name}->pointer,
+ 'has no keyid'
+ );
+ next;
+ }
+ my $keyid = $1;
+
+ # look for third-party signatures
+ my @thirdparty;
+ for my $packet (@packets) {
+
+ my $header = $packet->[0];
+ if ($header =~ qr/^:signature packet: algo \d+, keyid (\S*)$/){
+
+ my $signatory = $1;
+ push(@thirdparty, $signatory)
+ unless $signatory eq $keyid;
+ }
+ }
+
+ # signatures by parties other than self
+ my $extrasignatures = scalar @thirdparty;
+
+ # export-minimal strips such signatures
+ $self->pointed_hint(
+ 'public-upstream-key-not-minimal',
+ $key_items{$key_name}->pointer,
+ "has $extrasignatures extra signature(s) for keyid $keyid"
+ )if $extrasignatures;
+ }
+ }
+
+ return;
+}
+
+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/Lintian/Check/Debian/Variables.pm b/lib/Lintian/Check/Debian/Variables.pm
new file mode 100644
index 0000000..31fa9a4
--- /dev/null
+++ b/lib/Lintian/Check/Debian/Variables.pm
@@ -0,0 +1,60 @@
+# debian/variables -- lintian check script -*- perl -*-
+
+# Copyright (C) 2006 Russ Allbery <rra@debian.org>
+# Copyright (C) 2005 Rene van Bevern <rvb@pro-linux.de>
+# Copyright (C) 2019-2020 Chris Lamb <lamby@debian.org>
+# Copyright (C) 2021 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.
+
+package Lintian::Check::Debian::Variables;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Const::Fast;
+use List::SomeUtils qw(none);
+
+const my @WANTED_FILES => (qr{ (.+ [.])? install }sx, qr{ (.+ [.])? links }sx);
+
+const my @ILLEGAL_VARIABLES => qw(DEB_BUILD_MULTIARCH);
+
+use Moo;
+use namespace::clean;
+
+with 'Lintian::Check';
+
+sub visit_patched_files {
+ my ($self, $item) = @_;
+
+ return
+ unless $item->name =~ m{^ debian/ }sx;
+
+ return
+ if none { $item->name =~ m{ / $_ $}sx } @WANTED_FILES;
+
+ for my $variable (@ILLEGAL_VARIABLES) {
+
+ $self->pointed_hint('illegal-variable', $item->pointer, $variable)
+ if $item->decoded_utf8 =~ m{ \b $variable \b }msx;
+ }
+
+ return;
+}
+
+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/Lintian/Check/Debian/VersionSubstvars.pm b/lib/Lintian/Check/Debian/VersionSubstvars.pm
new file mode 100644
index 0000000..e3789b8
--- /dev/null
+++ b/lib/Lintian/Check/Debian/VersionSubstvars.pm
@@ -0,0 +1,206 @@
+# debian/version-substvars -- lintian check script -*- perl -*-
+#
+# Copyright (C) 2006 Adeodato Simo
+# Copyright (C) 2019 Chris Lamb <lamby@debian.org>
+# Copyright (C) 2021 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.
+
+# SUMMARY
+# =======
+#
+# What breaks
+# -----------
+#
+# (b1) any -> any (= ${source:Version}) -> use b:V
+# (b2) any -> all (= ${binary:Version}) [or S-V] -> use s:V
+# (b3) all -> any (= ${either-of-them}) -> use (>= ${s:V}),
+# optionally (<< ${s:V}.1~)
+#
+# Note (b2) also breaks if (>= ${binary:Version}) [or S-V] is used.
+#
+# Always warn on ${Source-Version} even if it doesn't break since the substvar
+# is now considered deprecated.
+
+package Lintian::Check::Debian::VersionSubstvars;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Const::Fast;
+use List::SomeUtils qw(any uniq);
+
+use Lintian::Relation;
+use Lintian::Util qw($PKGNAME_REGEX);
+
+use Moo;
+use namespace::clean;
+
+with 'Lintian::Check';
+
+const my $EMPTY => q{};
+const my $EQUAL => q{=};
+
+sub source {
+ my ($self) = @_;
+
+ my $debian_control = $self->processable->debian_control;
+
+ my @provides;
+ push(@provides,
+ $debian_control->installable_fields($_)
+ ->trimmed_list('Provides', qr/\s*,\s*/))
+ for $debian_control->installables;
+
+ for my $installable ($debian_control->installables) {
+
+ my $installable_control
+ = $debian_control->installable_fields($installable);
+
+ for my $field (
+ qw(Depends Pre-Depends Recommends Suggests Conflicts Replaces)) {
+
+ next
+ unless $installable_control->declares($field);
+
+ my $position = $installable_control->position($field);
+
+ my $relation
+ = $self->processable->binary_relation($installable, $field);
+
+ $self->pointed_hint(
+ 'substvar-source-version-is-deprecated',
+ $debian_control->item->pointer($position),
+ $installable, $field
+ )if $relation->matches(qr/\$[{]Source-Version[}]/);
+
+ my %external;
+ my $visitor = sub {
+ my ($value) = @_;
+
+ if (
+ $value
+ =~m{^($PKGNAME_REGEX)(?: :[-a-z0-9]+)? \s* # pkg-name $1
+ \(\s*[\>\<]?[=\>\<]\s* # REL
+ (\$[{](?:source:|binary:)(?:Upstream-)?Version[}]) # {subvar}
+ }x
+ ) {
+ my $other = $1;
+ my $substvar = $2;
+
+ $external{$substvar} //= [];
+ push(@{ $external{$substvar} }, $other);
+ }
+ };
+ $relation->visit($visitor, Lintian::Relation::VISIT_PRED_FULL);
+
+ for my $substvar (keys %external) {
+ for my $other (uniq @{ $external{$substvar} }) {
+
+ # We can't test dependencies on packages whose names are
+ # formed via substvars expanded during the build. Assume
+ # those maintainers know what they're doing.
+ $self->pointed_hint(
+ 'version-substvar-for-external-package',
+ $debian_control->item->pointer($position),
+ $field,
+ $substvar,
+ "$installable -> $other"
+ )
+ unless $debian_control->installable_fields($other)
+ ->declares('Architecture')
+ || (any { "$other (= $substvar)" eq $_ } @provides)
+ || $other =~ /\$\{\S+\}/;
+ }
+ }
+ }
+
+ my @pre_depends
+ = $installable_control->trimmed_list('Pre-Depends', qr/\s*,\s*/);
+ my @depends
+ = $installable_control->trimmed_list('Depends', qr/\s*,\s*/);
+
+ for my $versioned (uniq(@pre_depends, @depends)) {
+
+ next
+ unless $versioned
+ =~m{($PKGNAME_REGEX)(?: :any)? \s* # pkg-name
+ \(\s*([>]?=)\s* # rel
+ \$[{]((?:Source-|source:|binary:)Version)[}] # subvar
+ }x;
+
+ my $prerequisite = $1;
+ my $operator = $2;
+ my $substvar = $3;
+
+ my $prerequisite_control
+ = $debian_control->installable_fields($prerequisite);
+
+ # external relation or subst var package; handled above
+ next
+ unless $prerequisite_control->declares('Architecture');
+
+ my $prerequisite_is_all
+ = ($prerequisite_control->value('Architecture') eq 'all');
+ my $installable_is_all
+ = ($installable_control->value('Architecture') eq 'all');
+
+ my $context = "$installable -> $prerequisite";
+
+ # (b1) any -> any (= ${source:Version})
+ $self->hint('not-binnmuable-any-depends-any', $context)
+ if !$installable_is_all
+ && !$prerequisite_is_all
+ && $operator eq $EQUAL
+ && $substvar eq 'source:Version';
+
+ # (b2) any -> all (= ${binary:Version}) [or S-V]
+ $self->hint('maybe-not-arch-all-binnmuable', $context)
+ if !$installable_is_all
+ && $prerequisite_is_all
+ && $operator eq $EQUAL
+ && $substvar eq 'source:Version';
+
+ # (b2) any -> all (* ${binary:Version}) [or S-V]
+ $self->hint('not-binnmuable-any-depends-all', $context)
+ if !$installable_is_all
+ && $prerequisite_is_all
+ && $substvar ne 'source:Version';
+
+ # (b3) all -> any (= ${either-of-them})
+ $self->hint('not-binnmuable-all-depends-any', $context)
+ if $installable_is_all
+ && !$prerequisite_is_all
+ && $operator eq $EQUAL;
+
+ # any -> any (>= ${source:Version})
+ # technically this can be "binNMU'ed", though it is
+ # a bit weird.
+ }
+ }
+
+ return;
+}
+
+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/Lintian/Check/Debian/Watch.pm b/lib/Lintian/Check/Debian/Watch.pm
new file mode 100644
index 0000000..2f891d3
--- /dev/null
+++ b/lib/Lintian/Check/Debian/Watch.pm
@@ -0,0 +1,379 @@
+# debian/watch -- lintian check script -*- perl -*-
+#
+# Copyright (C) 2008 Patrick Schoenfeld
+# Copyright (C) 2008 Russ Allbery
+# Copyright (C) 2008 Raphael Geissert
+# 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 Lintian::Check::Debian::Watch;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Const::Fast;
+use List::SomeUtils qw(any firstval firstres);
+use Path::Tiny;
+
+use Lintian::Util qw($PKGREPACK_REGEX);
+
+use Moo;
+use namespace::clean;
+
+with 'Lintian::Check';
+
+const my $EMPTY => q{};
+const my $SPACE => q{ };
+
+const my $URL_ACTION_FIELDS => 4;
+const my $VERSION_ACTION_FIELDS => 3;
+
+const my $DMANGLES_AUTOMATICALLY => 4;
+
+sub source {
+ my ($self) = @_;
+
+ my $item = $self->processable->patched->resolve_path('debian/watch');
+ unless ($item && $item->is_file) {
+
+ $self->hint('debian-watch-file-is-missing')
+ unless $self->processable->native;
+
+ return;
+ }
+
+ # Perform the other checks even if it is a native package
+ $self->pointed_hint('debian-watch-file-in-native-package', $item->pointer)
+ if $self->processable->native;
+
+ # Check if the Debian version contains anything that resembles a repackaged
+ # source package sign, for fine grained version mangling check
+ # If the version field is missing, we assume a neutral non-native one.
+
+ # upstream method returns empty for native packages
+ my $upstream = $self->processable->changelog_version->upstream;
+ my ($prerelease) = ($upstream =~ qr/(alpha|beta|rc)/i);
+
+# there is a good repack indicator in $processable->repacked but we need the text
+ my ($repack) = ($upstream =~ $PKGREPACK_REGEX);
+
+ return
+ unless $item->is_open_ok;
+
+ my $contents = $item->bytes;
+
+ # each pattern marks a multi-line (!) selection for the tag message
+ my @templatepatterns
+ = (qr/^\s*#\s*(Example watch control file for uscan)/mi,qr/(<project>)/);
+ my $templatestring;
+
+ for my $pattern (@templatepatterns) {
+ ($templatestring) = ($contents =~ $pattern);
+ last if defined $templatestring;
+ }
+
+ $self->pointed_hint('debian-watch-contains-dh_make-template',
+ $item->pointer, $templatestring)
+ if length $templatestring;
+
+ # remove backslash at end; uscan will catch it
+ $contents =~ s/(?<!\\)\\$//;
+
+ my $standard;
+
+ my @lines = split(/\n/, $contents);
+
+ # look for watch file version
+ for my $line (@lines) {
+
+ if ($line =~ /^\s*version\s*=\s*(\d+)\s*$/) {
+ if (length $1) {
+ $standard = $1;
+ last;
+ }
+ }
+ }
+
+ return
+ unless defined $standard;
+
+ # version 1 too broken to check
+ return
+ if $standard < 2;
+
+ # allow spaces for all watch file versions (#950250, #950277)
+ my $separator = qr/\s*,\s*/;
+
+ my $withpgpverification = 0;
+ my %dversions;
+
+ my $position = 1;
+ my $continued = $EMPTY;
+ for my $line (@lines) {
+
+ my $pointer = $item->pointer($position);
+
+ # strip leading spaces
+ $line =~ s/^\s*//;
+
+ # strip comments, if any
+ $line =~ s/^\#.*$//;
+
+ unless (length $line) {
+ $continued = $EMPTY;
+ next;
+ }
+
+ # merge continuation lines
+ if ($line =~ s/\\$//) {
+ $continued .= $line;
+ next;
+ }
+
+ $line = $continued . $line
+ if length $continued;
+
+ $continued = $EMPTY;
+
+ next
+ if $line =~ /^version\s*=\s*\d+\s*$/;
+
+ my $remainder = $line;
+
+ my @options;
+
+ # keep order; otherwise. alternative \S+ ends up with quotes
+ if ($remainder =~ s/opt(?:ion)?s=(?|\"((?:[^\"]|\\\")+)\"|(\S+))\s+//){
+ @options = split($separator, $1);
+ }
+
+ unless (length $remainder) {
+
+ $self->pointed_hint('debian-watch-line-invalid', $pointer, $line);
+ next;
+ }
+
+ my $repack_mangle = 0;
+ my $repack_dmangle = 0;
+ my $repack_dmangle_auto = 0;
+ my $prerelease_mangle = 0;
+ my $prerelease_umangle = 0;
+
+ for my $option (@options) {
+
+ if (length $repack) {
+ $repack_mangle = 1
+ if $option
+ =~ /^[ud]?versionmangle\s*=\s*(?:auto|.*$repack.*)/;
+ $repack_dmangle = 1
+ if $option =~ /^dversionmangle\s*=\s*(?:auto|.*$repack.*)/;
+ }
+
+ if (length $prerelease) {
+ $prerelease_mangle = 1
+ if $option =~ /^[ud]?versionmangle\s*=.*$prerelease/;
+ $prerelease_umangle = 1
+ if $option =~ /^uversionmangle\s*=.*$prerelease/;
+ }
+
+ $repack_dmangle_auto = 1
+ if $option =~ /^dversionmangle\s*=.*(?:s\/\@DEB_EXT\@\/|auto)/
+ && $standard >= $DMANGLES_AUTOMATICALLY;
+
+ $withpgpverification = 1
+ if $option =~ /^pgpsigurlmangle\s*=\s*/
+ || $option =~ /^pgpmode\s*=\s*(?!none\s*$)\S.*$/;
+
+ my ($name, $value) = split(m{ \s* = \s* }x, $option, 2);
+
+ next
+ unless length $name;
+
+ $value //= $EMPTY;
+
+ $self->pointed_hint('prefer-uscan-symlink',$pointer, $name, $value)
+ if $name eq 'filenamemangle';
+ }
+
+ $self->pointed_hint(
+ 'debian-watch-file-uses-deprecated-sf-redirector-method',
+ $pointer,$remainder)
+ if $remainder =~ m{qa\.debian\.org/watch/sf\.php\?};
+
+ $self->pointed_hint('debian-watch-file-uses-deprecated-githubredir',
+ $pointer, $remainder)
+ if $remainder =~ m{githubredir\.debian\.net};
+
+ $self->pointed_hint('debian-watch-lacks-sourceforge-redirector',
+ $pointer, $remainder)
+ if $remainder =~ m{ (?:https?|ftp)://
+ (?:(?:.+\.)?dl|(?:pr)?downloads?|ftp\d?|upload) \.
+ (?:sourceforge|sf)\.net}xsm
+ || $remainder =~ m{https?://(?:www\.)?(?:sourceforge|sf)\.net
+ /project/showfiles\.php}xsm
+ || $remainder =~ m{https?://(?:www\.)?(?:sourceforge|sf)\.net
+ /projects/.+/files}xsm;
+
+ if ($remainder =~ m{((?:http|ftp):(?!//sf.net/)\S+)}) {
+ $self->pointed_hint('debian-watch-uses-insecure-uri', $pointer,$1);
+ }
+
+ # This bit is as-is from uscan.pl:
+ my ($base, $filepattern, $lastversion, $action)
+ = split($SPACE, $remainder, $URL_ACTION_FIELDS);
+
+ # Per #765995, $base might be undefined.
+ if (defined $base) {
+ if ($base =~ s{/([^/]*\([^/]*\)[^/]*)$}{/}) {
+ # Last component of $base has a pair of parentheses, so no
+ # separate filepattern field; we remove the filepattern from the
+ # end of $base and rescan the rest of the line
+ $filepattern = $1;
+ (undef, $lastversion, $action)
+ = split($SPACE, $remainder, $VERSION_ACTION_FIELDS);
+ }
+
+ $dversions{$lastversion} = 1
+ if defined $lastversion;
+
+ $lastversion = 'debian'
+ unless defined $lastversion;
+ }
+
+ # If the version of the package contains dfsg, assume that it needs
+ # to be mangled to get reasonable matches with upstream.
+ my $needs_repack_mangling = ($repack && $lastversion eq 'debian');
+
+ $self->pointed_hint('debian-watch-not-mangling-version',
+ $pointer, $line)
+ if $needs_repack_mangling
+ && !$repack_mangle
+ && !$repack_dmangle_auto;
+
+ $self->pointed_hint('debian-watch-mangles-debian-version-improperly',
+ $pointer, $line)
+ if $needs_repack_mangling
+ && $repack_mangle
+ && !$repack_dmangle;
+
+ my $needs_prerelease_mangling
+ = ($prerelease && $lastversion eq 'debian');
+
+ $self->pointed_hint('debian-watch-mangles-upstream-version-improperly',
+ $pointer, $line)
+ if $needs_prerelease_mangling
+ && $prerelease_mangle
+ && !$prerelease_umangle;
+
+ my $upstream_url = $remainder;
+
+ # Keep only URL part
+ $upstream_url =~ s/(.*?\S)\s.*$/$1/;
+
+ for my $option (@options) {
+ if ($option =~ /^ component = (.+) $/x) {
+
+ my $component = $1;
+
+ $self->pointed_hint('debian-watch-upstream-component',
+ $pointer, $upstream_url, $component);
+ }
+ }
+
+ } continue {
+ ++$position;
+ }
+
+ $self->pointed_hint('debian-watch-does-not-check-openpgp-signature',
+ $item->pointer)
+ unless $withpgpverification;
+
+ my $SIGNING_KEY_FILENAMES
+ = $self->data->load('common/signing-key-filenames');
+
+ # look for upstream signing key
+ my @candidates
+ = map { $self->processable->patched->resolve_path("debian/$_") }
+ $SIGNING_KEY_FILENAMES->all;
+ my $keyfile = firstval {$_ && $_->is_file} @candidates;
+
+ # check upstream key is present if needed
+ $self->pointed_hint('debian-watch-file-pubkey-file-is-missing',
+ $item->pointer)
+ if $withpgpverification && !$keyfile;
+
+ # check upstream key is used if present
+ $self->pointed_hint('debian-watch-could-verify-download',
+ $item->pointer, $keyfile->name)
+ if $keyfile && !$withpgpverification;
+
+ if (defined $self->processable->changelog && %dversions) {
+
+ my %changelog_versions;
+ my $count = 1;
+ my $changelog = $self->processable->changelog;
+ for my $entry (@{$changelog->entries}) {
+ my $uversion = $entry->Version;
+ $uversion =~ s/-[^-]+$//; # revision
+ $uversion =~ s/^\d+://; # epoch
+ $changelog_versions{'orig'}{$entry->Version} = $count;
+
+ # Preserve the first value here to correctly detect old versions.
+ $changelog_versions{'mangled'}{$uversion} = $count
+ unless (exists($changelog_versions{'mangled'}{$uversion}));
+ $count++;
+ }
+
+ for my $dversion (sort keys %dversions) {
+
+ next
+ if $dversion eq 'debian';
+
+ local $" = ', ';
+
+ if (!$self->processable->native
+ && exists($changelog_versions{'orig'}{$dversion})) {
+
+ $self->pointed_hint(
+ 'debian-watch-file-specifies-wrong-upstream-version',
+ $item->pointer, $dversion);
+ next;
+ }
+
+ if (exists $changelog_versions{'mangled'}{$dversion}
+ && $changelog_versions{'mangled'}{$dversion} != 1) {
+
+ $self->pointed_hint(
+ 'debian-watch-file-specifies-old-upstream-version',
+ $item->pointer, $dversion);
+ next;
+ }
+ }
+ }
+
+ return;
+}
+
+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/Lintian/Check/Debian/Watch/Standard.pm b/lib/Lintian/Check/Debian/Watch/Standard.pm
new file mode 100644
index 0000000..129966d
--- /dev/null
+++ b/lib/Lintian/Check/Debian/Watch/Standard.pm
@@ -0,0 +1,98 @@
+# debian/watch/standard -- lintian check script -*- perl -*-
+#
+# 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 Lintian::Check::Debian::Watch::Standard;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Const::Fast;
+use List::Compare;
+use List::Util qw(max);
+
+use Moo;
+use namespace::clean;
+
+with 'Lintian::Check';
+
+const my $SPACE => q{ };
+
+const my @STANDARDS => (2, 3, 4);
+const my $NEWLY_SUPERSEEDED => 3;
+
+sub visit_patched_files {
+ my ($self, $item) = @_;
+
+ return
+ unless $item->name eq 'debian/watch';
+
+ my $contents = $item->bytes;
+ return
+ unless length $contents;
+
+ # look for version
+ my @mentioned = ($contents =~ /^ version \s* = \s* (\d+) \s* $/gmsx);
+
+ my $has_contents = !!($contents =~ m{^ \s* [^#] }gmx);
+
+ if ($has_contents && !@mentioned) {
+
+ $self->pointed_hint('missing-debian-watch-file-standard',
+ $item->pointer);
+ return;
+ }
+
+ $self->pointed_hint('multiple-debian-watch-file-standards',
+ $item->pointer,join($SPACE, @mentioned))
+ if @mentioned > 1;
+
+ my $standard_lc = List::Compare->new(\@mentioned, \@STANDARDS);
+ my @unknown = $standard_lc->get_Lonly;
+ my @known = $standard_lc->get_intersection;
+
+ $self->pointed_hint('unknown-debian-watch-file-standard',
+ $item->pointer, $_)
+ for @unknown;
+
+ return
+ unless @known;
+
+ my $highest = max(@known);
+ $self->pointed_hint('debian-watch-file-standard', $item->pointer,$highest);
+
+ $self->pointed_hint('older-debian-watch-file-standard',
+ $item->pointer, $highest)
+ if $highest == $NEWLY_SUPERSEEDED;
+
+ $self->pointed_hint('obsolete-debian-watch-file-standard',
+ $item->pointer, $highest)
+ if $highest < $NEWLY_SUPERSEEDED;
+
+ return;
+}
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et