diff options
| author | Daniel Baumann <daniel.baumann@progress-linux.org> | 2024-04-14 13:42:30 +0000 |
|---|---|---|
| committer | Daniel Baumann <daniel.baumann@progress-linux.org> | 2024-04-14 13:42:30 +0000 |
| commit | 75808db17caf8b960b351e3408e74142f4c85aac (patch) | |
| tree | 7989e9c09a4240248bf4658a22208a0a52d991c4 /lib/Lintian/Check/Debian | |
| parent | Initial commit. (diff) | |
| download | lintian-75808db17caf8b960b351e3408e74142f4c85aac.tar.xz lintian-75808db17caf8b960b351e3408e74142f4c85aac.zip | |
Adding upstream version 2.117.0.upstream/2.117.0upstream
Signed-off-by: Daniel Baumann <daniel.baumann@progress-linux.org>
Diffstat (limited to 'lib/Lintian/Check/Debian')
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 |