summaryrefslogtreecommitdiffstats
path: root/lib/Lintian/Check/Fields/Vcs.pm
diff options
context:
space:
mode:
authorDaniel Baumann <daniel.baumann@progress-linux.org>2024-04-14 13:42:30 +0000
committerDaniel Baumann <daniel.baumann@progress-linux.org>2024-04-14 13:42:30 +0000
commit75808db17caf8b960b351e3408e74142f4c85aac (patch)
tree7989e9c09a4240248bf4658a22208a0a52d991c4 /lib/Lintian/Check/Fields/Vcs.pm
parentInitial commit. (diff)
downloadlintian-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/Fields/Vcs.pm')
-rw-r--r--lib/Lintian/Check/Fields/Vcs.pm378
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