diff options
Diffstat (limited to 'lib/Lintian/Check/Fields/Vcs.pm')
| -rw-r--r-- | lib/Lintian/Check/Fields/Vcs.pm | 378 |
1 files changed, 378 insertions, 0 deletions
diff --git a/lib/Lintian/Check/Fields/Vcs.pm b/lib/Lintian/Check/Fields/Vcs.pm new file mode 100644 index 0000000..8bf7858 --- /dev/null +++ b/lib/Lintian/Check/Fields/Vcs.pm @@ -0,0 +1,378 @@ +# fields/vcs -- lintian check script (rewrite) -*- perl -*- +# +# Copyright (C) 2004 Marc Brockschmidt +# Copyright (C) 2019 Chris Lamb <lamby@debian.org> +# +# 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::Fields::Vcs; + +use v5.20; +use warnings; +use utf8; + +use Const::Fast; +use List::SomeUtils qw(any); + +const my $EMPTY => q{}; +const my $QUESTION_MARK => q{?}; + +const my $NOT_EQUALS => q{!=}; + +use Moo; +use namespace::clean; + +with 'Lintian::Check'; + +my %VCS_EXTRACT = ( + Browser => sub { return @_;}, + Arch => sub { return @_;}, + Bzr => sub { return @_;}, + # cvs rootdir followed by optional module name: + Cvs => sub { return shift =~ /^(.+?)(?:\s+(\S*))?$/;}, + Darcs => sub { return @_;}, + # hg uri followed by optional -b branchname + Hg => sub { return shift =~ /^(.+?)(?:\s+-b\s+(\S*))?$/;}, + # git uri followed by optional "[subdir]", "-b branchname" etc. + Git => sub { + return shift =~ /^(.+?)(?:(?:\s+\[(\S*)\])?(?:\s+-b\s+(\S*))?){0,2}$/; + }, + Svn => sub { return @_;}, + # New "mtn://host?branch" uri or deprecated "host branch". + Mtn => sub { return shift =~ /^(.+?)(?:\s+\S+)?$/;}, +); + +my %VCS_CANONIFY = ( + Browser => sub { + $_[0] =~ s{https?://svn\.debian\.org/wsvn/} + {https://anonscm.debian.org/viewvc/}; + $_[0] =~ s{https?\Q://git.debian.org/?p=\E} + {https://anonscm.debian.org/git/}; + $_[0] =~ s{https?\Q://bzr.debian.org/loggerhead/\E} + {https://anonscm.debian.org/loggerhead/}; + $_[0] =~ s{https?\Q://salsa.debian.org/\E([^/]+/[^/]+)\.git/?$} + {https://salsa.debian.org/$1}; + + if ($_[0] =~ m{https?\Q://anonscm.debian.org/viewvc/\E}xsm) { + if ($_[0] =~ s{\?(.*[;\&])?op=log(?:[;\&](.*))?\Z}{}xsm) { + my (@keep) = ($1, $2, $3); + my $final = join($EMPTY, grep {defined} @keep); + + $_[0] .= $QUESTION_MARK . $final + if $final ne $EMPTY; + + $_[1] = 'vcs-field-bitrotted'; + } + } + }, + Cvs => sub { + if ( + $_[0] =~ s{\@(?:cvs\.alioth|anonscm)\.debian\.org:/cvsroot/} + {\@anonscm.debian.org:/cvs/} + ) { + $_[1] = 'vcs-field-bitrotted'; + } + $_[0]=~ s{\@\Qcvs.alioth.debian.org:/cvs/}{\@anonscm.debian.org:/cvs/}; + }, + Arch => sub { + $_[0] =~ s{https?\Q://arch.debian.org/arch/\E} + {https://anonscm.debian.org/arch/}; + }, + Bzr => sub { + $_[0] =~ s{https?\Q://bzr.debian.org/\E} + {https://anonscm.debian.org/bzr/}; + $_[0] =~ s{https?\Q://anonscm.debian.org/bzr/bzr/\E} + {https://anonscm.debian.org/bzr/}; + }, + Git => sub { + if ( + $_[0] =~ s{git://(?:git|anonscm)\.debian\.org/~} + {https://anonscm.debian.org/git/users/} + ) { + $_[1] = 'vcs-git-uses-invalid-user-uri'; + } + $_[0] =~ s{(https?://.*?\.git)(?:\.git)+$}{$1}; + $_[0] =~ s{https?\Q://git.debian.org/\E(?:git/?)?} + {https://anonscm.debian.org/git/}; + $_[0] =~ s{https?\Q://anonscm.debian.org/git/git/\E} + {https://anonscm.debian.org/git/}; + $_[0] =~ s{\Qgit://git.debian.org/\E(?:git/?)?} + {https://anonscm.debian.org/git/}; + $_[0] =~ s{\Qgit://anonscm.debian.org/git/\E} + {https://anonscm.debian.org/git/}; + $_[0] =~ s{https?\Q://salsa.debian.org/\E([^/]+/[^/\.]+)(?!\.git)$} + {https://salsa.debian.org/$1.git}; + }, + Hg => sub { + $_[0] =~ s{https?\Q://hg.debian.org/\E} + {https://anonscm.debian.org/hg/}; + $_[0] =~ s{https?\Q://anonscm.debian.org/hg/hg/\E} + {https://anonscm.debian.org/hg/}; + }, + Svn => sub { + $_[0] =~ s{\Qsvn://cvs.alioth.debian.org/\E} + {svn://anonscm.debian.org/}; + $_[0] =~ s{\Qsvn://svn.debian.org/\E} + {svn://anonscm.debian.org/}; + $_[0] =~ s{\Qsvn://anonscm.debian.org/svn/\E} + {svn://anonscm.debian.org/}; + }, +); + +# Valid URI formats for the Vcs-* fields +# currently only checks the protocol, not the actual format of the URI +my %VCS_RECOMMENDED_URIS = ( + Browser => qr{^https?://}, + Arch => qr{^https?://}, + Bzr => qr{^(?:lp:|(?:nosmart\+)?https?://)}, + Cvs => qr{^:(?:pserver:|ext:_?anoncvs)}, + Darcs => qr{^https?://}, + Hg => qr{^https?://}, + Git => qr{^(?:git|https?|rsync)://}, + Svn => qr{^(?:svn|(?:svn\+)?https?)://}, + Mtn => qr{^mtn://}, +); + +my %VCS_VALID_URIS = ( + Arch => qr{^https?://}, + Bzr => qr{^(?:sftp|(?:bzr\+)?ssh)://}, + Cvs => qr{^(?:-d\s*)?:(?:ext|pserver):}, + Hg => qr{^ssh://}, + Git => qr{^(?:git\+)?ssh://|^[\w.]+@[a-zA-Z0-9.]+:[/a-zA-Z0-9.]}, + Svn => qr{^(?:svn\+)?ssh://}, + Mtn => qr{^[\w.-]+$}, +); + +has VCS_HOSTERS_BY_PATTERN => ( + is => 'rw', + lazy => 1, + default => sub { + my ($self) = @_; + + my %vcs_hosters_by_pattern; + + my $KNOWN_VCS_HOSTERS + = $self->data->load('fields/vcs-hosters',qr/\s*~~\s*/); + + for my $pattern ($KNOWN_VCS_HOSTERS->all) { + + my @known_hosters + = split(m{,}, $KNOWN_VCS_HOSTERS->value($pattern)); + $vcs_hosters_by_pattern{$pattern} = \@known_hosters; + } + + return \%vcs_hosters_by_pattern; + } +); + +sub always { + my ($self) = @_; + + my $type = $self->processable->type; + my $processable = $self->processable; + + # team-maintained = maintainer or uploaders field contains a mailing list + my $is_teammaintained = 0; + my $team_email = $EMPTY; + # co-maintained = maintained by an informal group of people, + # i. e. >= 1 uploader and not team-maintained + my $is_comaintained = 0; + my $is_maintained_by_individual = 1; + my $num_uploaders = 0; + for my $field (qw(Maintainer Uploaders)) { + + next + unless $processable->fields->declares($field); + + my $maintainer = $processable->fields->unfolded_value($field); + + if ($maintainer =~ /\b(\S+\@lists(?:\.alioth)?\.debian\.org)\b/ + || $maintainer =~ /\b(\S+\@tracker\.debian\.org)\b/) { + $is_teammaintained = 1; + $team_email = $1; + $is_maintained_by_individual = 0; + } + + if ($field eq 'Uploaders') { + + # check for empty field see #783628 + $maintainer =~ s/,\s*,/,/g + if $maintainer =~ m/,\s*,/; + + my @uploaders = map { split /\@\S+\K\s*,\s*/ } + split />\K\s*,\s*/, $maintainer; + + $num_uploaders = scalar @uploaders; + + if (@uploaders) { + $is_comaintained = 1 + unless $is_teammaintained; + $is_maintained_by_individual = 0; + } + + } + } + + $self->hint('package-is-team-maintained', $team_email, + "(with $num_uploaders uploaders)") + if $is_teammaintained; + $self->hint('package-is-co-maintained', "(with $num_uploaders uploaders)") + if $is_comaintained; + $self->hint('package-is-maintained-by-individual') + if $is_maintained_by_individual; + + my %seen_vcs; + for my $platform (keys %VCS_EXTRACT) { + + my $splitter = $VCS_EXTRACT{$platform}; + + my $fieldname = "Vcs-$platform"; + my $maintainer = $processable->fields->value('Maintainer'); + + next + unless $processable->fields->declares($fieldname); + + my $uri = $processable->fields->unfolded_value($fieldname); + + my @parts = $splitter->($uri); + if (not @parts or not $parts[0]) { + $self->hint('vcs-field-uses-unknown-uri-format', $platform, $uri); + } else { + if ( $VCS_RECOMMENDED_URIS{$platform} + and $parts[0] !~ $VCS_RECOMMENDED_URIS{$platform}) { + if ( $VCS_VALID_URIS{$platform} + and $parts[0] =~ $VCS_VALID_URIS{$platform}) { + $self->hint('vcs-field-uses-not-recommended-uri-format', + $platform, $uri); + } else { + $self->hint('vcs-field-uses-unknown-uri-format', + $platform,$uri); + } + } + + $self->hint('vcs-field-has-unexpected-spaces', $platform, $uri) + if (any { $_ and /\s/} @parts); + + $self->hint('vcs-field-uses-insecure-uri', $platform, $uri) + if $parts[0] =~ m{^(?:git|(?:nosmart\+)?http|svn)://} + || $parts[0] =~ m{^(?:lp|:pserver):}; + } + + if ($VCS_CANONIFY{$platform}) { + + my $canonicalized = $parts[0]; + my $tag = 'vcs-field-not-canonical'; + + foreach my $canonify ($VCS_CANONIFY{$platform}) { + $canonify->($canonicalized, $tag); + } + + $self->hint($tag, $platform, $parts[0], $canonicalized) + unless $canonicalized eq $parts[0]; + } + + if ($platform eq 'Browser') { + + $self->hint('vcs-browser-links-to-empty-view', $uri) + if $uri =~ /rev=0&sc=0/; + + } else { + $self->hint('vcs', lc $platform); + $self->hint('vcs-uri', $platform, $uri); + $seen_vcs{$platform}++; + + for my $pattern (keys %{$self->VCS_HOSTERS_BY_PATTERN}) { + + # warn once + my $known_hoster + = @{$self->VCS_HOSTERS_BY_PATTERN->{$pattern}}[0]; + + $self->hint('vcs-field-mismatch', + "Vcs-$platform", $NOT_EQUALS, "Vcs-$known_hoster",$uri) + if $uri =~ m/^ $pattern /xi + && $platform ne $known_hoster + && $platform ne 'Browser'; + } + } + + if ($uri =~ m{//(.+)\.debian\.org/}) { + + $self->hint('vcs-obsolete-in-debian-infrastructure', + $platform, $uri) + unless $1 =~ m{^(?:salsa|.*\.dgit)$}; + + } + + # orphaned + if ($maintainer =~ /packages\@qa.debian.org/ && $platform ne 'Browser') + { + if ($uri =~ m{//(?:.+)\.debian\.org/}) { + + $self->hint('orphaned-package-maintained-in-private-space', + $fieldname, $uri) + unless $uri =~ m{//salsa\.debian\.org/debian/} + || $uri =~ m{//git\.dgit\.debian\.org/}; + + } else { + + $self->hint( + 'orphaned-package-not-maintained-in-debian-infrastructure', + $fieldname, $uri + ); + } + } + } + + $self->hint('vcs-fields-use-more-than-one-vcs', + (sort map { lc } keys %seen_vcs)) + if keys %seen_vcs > 1; + + $self->hint('co-maintained-package-with-no-vcs-fields') + if $type eq 'source' + and ($is_comaintained or $is_teammaintained) + and not %seen_vcs; + + # Check for missing Vcs-Browser headers + unless ($processable->fields->declares('Vcs-Browser')) { + + for my $pattern (keys %{$self->VCS_HOSTERS_BY_PATTERN}) { + + # warn once + my $platform = @{$self->VCS_HOSTERS_BY_PATTERN->{$pattern}}[0]; + + my $fieldname = "Vcs-$platform"; + my $url = $processable->fields->value($fieldname); + + $self->hint('missing-vcs-browser-field', $fieldname, $url) + if $url =~ m/^ $pattern /xi; + } + } + + return; +} + +1; + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et |