diff options
Diffstat (limited to 'lib/Lintian/Check/Debian/Watch.pm')
| -rw-r--r-- | lib/Lintian/Check/Debian/Watch.pm | 379 |
1 files changed, 379 insertions, 0 deletions
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 |