# fields -- lintian check script (rewrite) -*- perl -*- # # Copyright (C) 2004 Marc Brockschmidt # # 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 http://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::fields; use strict; use warnings; use Dpkg::Version qw(version_check); use Util; use Lintian::Architecture qw(:all); use Lintian::Data (); use Lintian::Check qw(check_maintainer); use Lintian::Relation (); use Lintian::Relation::Version qw(versions_compare); use Lintian::Tags qw(tag); our $KNOWN_ESSENTIAL = Lintian::Data->new('fields/essential'); our $KNOWN_METAPACKAGES = Lintian::Data->new('fields/metapackages'); our $NO_BUILD_DEPENDS = Lintian::Data->new('fields/no-build-depends'); our $KNOWN_SECTIONS = Lintian::Data->new('fields/archive-sections'); our $known_build_essential = Lintian::Data->new('fields/build-essential-packages'); our $KNOWN_BINARY_FIELDS = Lintian::Data->new('fields/binary-fields'); our $KNOWN_UDEB_FIELDS = Lintian::Data->new('fields/udeb-fields'); our %KNOWN_ARCHIVE_PARTS = map { $_ => 1 } ('non-free', 'contrib'); my $KNOWN_PRIOS = Lintian::Data->new ('common/priorities', qr/\s*=\s*/o); our %known_obsolete_fields = map { $_ => 1 } ('revision', 'package-revision', 'package_revision', 'recommended', 'optional', 'class'); our @supported_source_formats = ( qr/1\.0/, qr/3\.0\s*\((quilt|native)\)/ ); # Still in the archive but shouldn't be the primary Emacs dependency. our %known_obsolete_emacs = map { $_ => 1 } ('emacs21', 'emacs22'); our %known_libstdcs = map { $_ => 1 } ('libstdc++2.9-glibc2.1', 'libstdc++2.10', 'libstdc++2.10-glibc2.2', 'libstdc++3', 'libstdc++3.0', 'libstdc++4', 'libstdc++5', 'libstdc++6', 'lib64stdc++6', ); our %known_tcls = map { $_ => 1 } ( 'tcl74', 'tcl8.0', 'tcl8.2', 'tcl8.3', 'tcl8.4', 'tcl8.5', ); our %known_tclxs = map { $_ => 1 } ( 'tclx76', 'tclx8.0.4', 'tclx8.2', 'tclx8.3', 'tclx8.4', ); our %known_tks = map { $_ => 1 } ( 'tk40', 'tk8.0', 'tk8.2', 'tk8.3', 'tk8.4', 'tk8.5', ); our %known_tkxs = map { $_ => 1 } ( 'tkx8.2', 'tkx8.3', ); our %known_libpngs = map { $_ => 1 } ( 'libpng12-0', 'libpng2', 'libpng3', ); our @known_java_pkg = map { qr/$_/ } ('default-jre(?:-headless)?', 'default-jdk', # default java 'java\d*-runtime(?:-headless)?', # java-runtime and javaX-runtime alternatives (virtual) '(openjdk-|sun-java)\d+-jre(?:-headless)?', '(openjdk-|sun-java)\d+-jdk', # openjdk-X and sun-javaX 'gcj-(?:\d+\.\d+-)?jre(?:-headless)?', 'gcj-(?:\d+\.\d+-)?jdk', # gcj 'gij', 'java-gcj-compat(?:-dev|-headless)?', # deprecated/transitional packages 'kaffe', 'cacao', 'jamvm', 'classpath', # deprecated packages (removed in Squeeze) ); # Mapping of package names to section names my @NAME_SECTION_MAPPINGS = ( [ qr/-docs?$/ => 'doc' ], [ qr/-dbg$/ => 'debug' ], [ qr/^(?:python-)?zope/ => 'zope' ], [ qr/^python-/ => 'python' ], [ qr/^r-cran-/ => 'gnu-r' ], [ qr/^lib.*-perl$/ => 'perl' ], [ qr/^lib.*-cil$/ => 'cli-mono' ], [ qr/^lib.*-(?:java|gcj)$/ => 'java' ], [ qr/^(?:lib)php-/ => 'php' ], [ qr/^lib(?:hugs|ghc6?)-/ => 'haskell' ], [ qr/^lib.*-ruby(?:1\.\d)?$/ => 'ruby' ], [ qr/^lib.*-(?:ocaml|camlp4)-dev$/ => 'ocaml' ], [ qr/^lib.*-dev$/ => 'libdevel' ], ); # 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;^[\w.-]+\s+\S+;, # that's a hostname followed by a module name ); 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://;, svn => qr;^(?:svn\+)?ssh://;, ); # Python development packages that are used almost always just for building # architecture-dependent modules. Used to check for unnecessary build # dependencies for architecture-independent source packages. our $PYTHON_DEV = join(' | ', qw(python-dev python-all-dev python3-dev python3-all-dev), map { "python$_-dev" } qw(2.6 2.7 3 3.2)); our $PERL_CORE_PROVIDES = Lintian::Data->new('fields/perl-provides', '\s+'); our $OBSOLETE_PACKAGES = Lintian::Data->new('fields/obsolete-packages'); our $VIRTUAL_PACKAGES = Lintian::Data->new('fields/virtual-packages'); our $SOURCE_FIELDS = Lintian::Data->new('common/source-fields'); sub run { my $pkg = shift; my $type = shift; my $info = shift; my $proc = shift; my $version; my $arch_indep; #---- Format if ($type eq 'source') { my $format = $info->field('format'); if (defined($format)) { my $supported = 0; foreach my $f (@supported_source_formats){ if( $format =~ /^\s*$f\s*\z/ ){ $supported = 1; } } tag 'unsupported-source-format', $format unless $supported; } } #---- Package if ($type eq 'binary'){ if (not defined $info->field('package')) { tag 'no-package-name'; } else { my $name = $info->field('package'); unfold('package', \$name); tag 'bad-package-name' unless $name =~ /^[A-Z0-9][-+\.A-Z0-9]+$/i; tag 'package-not-lowercase' if ($name =~ /[A-Z]/) } } #---- Version if (not defined $info->field('version')) { tag 'no-version-field'; } else { $version = $info->field('version'); unfold('version', \$version); my $dversion = Dpkg::Version->new($version); if ($dversion->is_valid) { my ($upstream, $debian) = ($dversion->version, $dversion->revision); if ($upstream !~ /^\d/i) { tag 'upstream-version-not-numeric', $version; } # Dpkg::Version sets the debian revision to 0 if there is no revision. # - so we need to check if the raw version ends with "-0". tag 'debian-revision-should-not-be-zero', $version if $version =~ m/-0$/o; my $ubuntu; if($debian =~ m/^(?:[^.]+)(?:\.[^.]+)?(?:\.[^.]+)?(\..*)?$/o){ my $extra = $1; if (defined $extra && $debian =~ /^(?:[^.]+ubuntu[^.]+)(?:\.\d+){1,3}(\..*)?$/o){ $ubuntu = 1; $extra = $1; } if (defined $extra) { tag 'debian-revision-not-well-formed', $version; } } else { tag 'debian-revision-not-well-formed', $version; } if ($debian =~ /^[^.-]+\.[^.-]+\./o and not $ubuntu) { tag 'binary-nmu-uses-old-version-style', $version if $type eq 'binary'; tag 'binary-nmu-debian-revision-in-source', $version if $type eq 'source'; } if ($version =~ /\+b\d+$/ && $type eq 'source') { tag 'binary-nmu-debian-revision-in-source', $version; } # Checks for the dfsg convention for repackaged upstream # source. Only check these against the source package to not # repeat ourselves too much. if ($type eq 'source') { if ($version =~ /dfsg/ and $info->native) { tag 'dfsg-version-in-native-package', $version; } elsif ($version =~ /\.dfsg/) { tag 'dfsg-version-with-period', $version; } elsif ($version =~ /dsfg/) { tag 'dfsg-version-misspelled', $version; } } my $name = $info->field('package'); if ($name && $PERL_CORE_PROVIDES->known($name) && perl_core_has_version($name, '>=', $upstream)) { my $core_version = $PERL_CORE_PROVIDES->value($name); tag 'package-superseded-by-perl', "with $core_version" } } else { tag 'bad-version-number', $version; } } #---- Multi-Arch if (defined $info->field('multi-arch')){ my $march = $info->field('multi-arch'); unfold('multi-arch', \$march); tag 'unknown-multi-arch-value', $pkg, $march unless $march =~ m/^no|foreign|allowed|same$/o; if ($march eq 'same' && $type eq 'binary' && defined $info->field('architecture')){ my $arch = $info->field('architecture'); # Do not use unfold to avoid duplicate warning $arch =~ s/\n//o; tag 'illegal-multi-arch-value', $arch, $march if ($arch eq 'all'); } } #---- Architecture if (not defined $info->field('architecture')) { tag 'no-architecture-field'; } else { my $archs = $info->field('architecture'); unfold('architecture', \$archs); my @archs = split m/ /o, $archs; if (@archs > 1) { # Check for magic architecture combinations. my %archmap; my $magic = 0; $archmap{$_}++ for (@archs); $magic++ if ($type ne 'source' && $archmap{'all'}); if ($archmap{'any'}){ delete $archmap{'any'}; # Allow 'all' to be present in source packages as well (#626775) delete $archmap{'all'} if $type eq 'source'; $magic++ if %archmap; } tag 'magic-arch-in-arch-list' if $magic; } for my $arch (@archs) { tag 'unknown-architecture', $arch unless is_arch_or_wildcard ($arch); tag 'arch-wildcard-in-binary-package', $arch if ($type eq 'binary' && is_arch_wildcard ($arch)); } if ($type eq 'binary') { tag 'too-many-architectures' if (@archs > 1); if (@archs > 0) { tag 'aspell-package-not-arch-all' if ($pkg =~ /^aspell-[a-z]{2}(?:-.*)?$/ && $archs[0] ne 'all'); if ($pkg =~ /-docs?$/ && $archs[0] ne 'all') { tag 'documentation-package-not-architecture-independent'; } } } # Used for later tests. $arch_indep = 1 if (@archs == 1 && $archs[0] eq 'all'); } #---- Subarchitecture (udeb) if (defined $info->field('subarchitecture')) { my $subarch = $info->field('subarchitecture'); unfold('subarchitecture', \$subarch); } #---- Maintainer #---- Uploaders for my $f (qw(maintainer uploaders)) { if (not defined $info->field($f)) { tag 'no-maintainer-field' if $f eq 'maintainer'; } else { my $maintainer = $info->field($f); # Note, not expected to hit on uploaders anymore, as dpkg now strips # newlines for the .dsc, and the newlines don't hurt in debian/control unfold($f, \$maintainer); if ($f eq 'uploaders') { my %duplicate_uploaders; my @uploaders = map { split /\@\S+\K\s*,\s*/ } split />\K\s*,\s*/, $maintainer; for my $uploader (@uploaders) { check_maintainer($uploader, 'uploader'); if ( ((grep { $_ eq $uploader } @uploaders) > 1) and ($duplicate_uploaders{$uploader}++ == 0)) { tag 'duplicate-uploader', $uploader; } } } else { check_maintainer($maintainer, $f); if ($type eq 'source' && $maintainer =~ /\@lists(?:\.alioth)?\.debian\.org\b/ && ! defined $info->field('uploaders')) { tag 'no-human-maintainers'; } } } } if (defined $info->field('uploaders') && defined $info->field('maintainer')) { my $maint = $info->field('maintainer'); tag 'maintainer-also-in-uploaders' if $info->field('uploaders') =~ m/\Q$maint/; } #---- Source if (not defined $info->field('source')) { tag 'no-source-field' if $type eq 'source'; } else { my $source = $info->field('source'); unfold('source', \$source); if ($type eq 'source') { my $filename = $proc->pkg_path; my ($base) = ($filename =~ m,(?:\a|/)([^/]+)$,o); my ($n) = ($base =~ m/^([^_]+)_/o); if ($source ne $n) { tag 'source-field-does-not-match-pkg-name', "$source != $n"; } if ($source !~ /^[a-z0-9][-+\.a-z0-9]+\z/) { tag 'source-field-malformed', $source; } } elsif ($source !~ /^[a-z0-9][-+\.a-z0-9]+ # Package name \s* (?:\((?:\d+:)?(?:[-\.+:a-zA-Z0-9~]+?)(?:-[\.+a-zA-Z0-9~]+)?\))?\s*$/x) { #Version tag 'source-field-malformed', $source; } } #---- Essential if (defined $info->field('essential')) { my $essential = $info->field('essential'); unfold('essential', \$essential); tag 'essential-in-source-package' if ($type eq 'source'); tag 'essential-no-not-needed' if ($essential eq 'no'); tag 'unknown-essential-value' if ($essential ne 'no' and $essential ne 'yes'); if ($essential eq 'yes' and not $KNOWN_ESSENTIAL->known($pkg)) { tag 'new-essential-package'; } } #---- Section if (not defined $info->field('section')) { tag 'no-section-field' if ($type eq 'binary'); } else { my $section = $info->field('section'); unfold('section', \$section); if ($type eq 'udeb') { unless ($section eq 'debian-installer') { tag 'wrong-section-for-udeb', $section; } } else { my @parts = split /\//, $section, 2; if (scalar @parts > 1) { tag 'unknown-section', $section unless $KNOWN_ARCHIVE_PARTS{$parts[0]}; tag 'unknown-section', $section unless $KNOWN_SECTIONS->known($parts[1]); } elsif ($parts[0] eq 'unknown') { tag 'section-is-dh_make-template'; } else { tag 'unknown-section', $section unless $KNOWN_SECTIONS->known($parts[0]); } # Check package name <-> section. oldlibs is a special case; let # anything go there. if ($parts[-1] ne 'oldlibs') { foreach my $map (@NAME_SECTION_MAPPINGS) { next unless ($pkg =~ $map->[0]); my $area = ''; $area = "$parts[0]/" if (scalar @parts == 2); tag 'wrong-section-according-to-package-name', "$pkg => ${area}$map->[1]" unless $parts[-1] eq $map->[1]; last; } } if ($info->is_transitional) { my $pri = $info->field ('priority')//''; # Cannot use "unfold" as it could emit a tag for priority, # which will be duplicated below. $pri =~ s/\n//; tag 'transitional-package-should-be-oldlibs-extra', "$parts[-1]/$pri" unless $pri eq 'extra' && $parts[-1] eq 'oldlibs'; } } } #---- Priority if (not defined $info->field('priority')) { tag 'no-priority-field' if $type eq 'binary'; } else { my $priority = $info->field('priority'); unfold('priority', \$priority); tag 'unknown-priority', $priority unless $KNOWN_PRIOS->known ($priority); if ($pkg =~ /-dbg$/) { tag 'debug-package-should-be-priority-extra', $pkg unless $priority eq 'extra'; } } #---- Standards-Version # handled in checks/standards-version #---- Description # handled in checks/description #--- Homepage if (defined $info->field('homepage')) { my $homepage = $info->field('homepage'); my $orig = $homepage; unfold('homepage', \$homepage); if ($homepage =~ /^<(?:UR[LI]:)?.*>$/i) { tag 'superfluous-clutter-in-homepage', $orig; $homepage = substr($homepage, 1, length($homepage) - 2); } require URI; my $uri = URI->new($homepage); # not an absolute URI or (most likely) an invalid protocol unless ($uri->scheme && $uri->scheme =~ m/^ftp|https?|gopher$/o) { tag 'bad-homepage', $orig; } if ($homepage =~ m,/search\.cpan\.org/.*-[0-9._]+/*$,) { tag 'homepage-for-cpan-package-contains-version', $orig; } } elsif ($type eq 'binary' and not $info->native) { tag 'no-homepage-field'; } #---- Installer-Menu-Item (udeb) if (defined $info->field('installer-menu-item')) { my $menu_item = $info->field('installer-menu-item'); unfold('installer-menu-item', \$menu_item); $menu_item =~ /^\d+$/ or tag 'bad-menu-item', $menu_item; } #---- Package relations (binary package) # Check whether the package looks like a metapackage, used for later # dependency checks. We consider a package to possibly be a metapackage if # it is a binary package with no files outside of /usr/share/doc and a few # other directories found in metapackges. This also catches documentation # packages, but that doesn't matter for our purposes. my $metapackage = 0; if ($type eq 'binary') { $metapackage = 1; for my $file (@{$info->sorted_index}) { next if $info->index->{$file}->{type} =~ /^d/; next if $file =~ m%^usr/share/doc/%; next if $file =~ m%^usr/share/lintian/overrides/%; next if $file =~ m%^usr/share/cdd/%; $metapackage = 0; last; } # Packages we say are metapackages are always metapackages even if # they don't look like it. $metapackage = 1 if $KNOWN_METAPACKAGES->known($pkg); } if (($type eq 'binary') || ($type eq 'udeb')) { my (%fields, %parsed); my $javalib = 0; my $replaces = $info->relation('replaces'); my %nag_once = (); $javalib = 1 if($pkg =~ m/^lib.*-java$/o); for my $field (qw(depends pre-depends recommends suggests conflicts provides enhances replaces breaks)) { next unless defined $info->field($field); #Get data and clean it my $data = $info->field($field); my $javadep = 0; unfold($field, \$data); $fields{$field} = $data; my (@seen_libstdcs, @seen_tcls, @seen_tclxs, @seen_tks, @seen_tkxs, @seen_libpngs); my $is_dep_field = sub { grep { $_ eq $_[0] } qw(depends pre-depends recommends suggests) }; tag 'alternates-not-allowed', $field if ($data =~ /\|/ && ! &$is_dep_field($field)); for my $dep (split /\s*,\s*/, $data) { my (@alternatives, @seen_obsolete_packages); push @alternatives, [_split_dep($_), $_] for (split /\s*\|\s*/, $dep); if (&$is_dep_field($field)) { push @seen_libstdcs, $alternatives[0]->[0] if defined $known_libstdcs{$alternatives[0]->[0]}; push @seen_tcls, $alternatives[0]->[0] if defined $known_tcls{$alternatives[0]->[0]}; push @seen_tclxs, $alternatives[0]->[0] if defined $known_tclxs{$alternatives[0]->[0]}; push @seen_tks, $alternatives[0]->[0] if defined $known_tks{$alternatives[0]->[0]}; push @seen_tkxs, $alternatives[0]->[0] if defined $known_tkxs{$alternatives[0]->[0]}; push @seen_libpngs, $alternatives[0]->[0] if defined $known_libpngs{$alternatives[0]->[0]}; } # Only for (Pre-)?Depends. tag 'virtual-package-depends-without-real-package-depends', "$field: $alternatives[0]->[0]" if ($VIRTUAL_PACKAGES->known($alternatives[0]->[0]) && ($field eq 'depends' || $field eq 'pre-depends') && ($pkg ne 'base-files' || $alternatives[0]->[0] ne 'awk') # ignore phpapi- dependencies as adding an # alternative, real, package breaks its pourpose && $alternatives[0]->[0] !~ m/^phpapi-/); # Check defaults for transitions. Here, we only care that the first alternative is current. tag 'depends-on-old-emacs', "$field: $alternatives[0]->[0]" if (&$is_dep_field($field) && $known_obsolete_emacs{$alternatives[0]->[0]}); for my $part_d (@alternatives) { my ($d_pkg, $d_version, $d_arch, $rest, $part_d_orig) = @$part_d; tag 'versioned-provides', $part_d_orig if ($field eq 'provides' && $d_version->[0]); tag 'bad-provided-package-name', $d_pkg if $d_pkg !~ /^[a-z0-9][-+\.a-z0-9]+$/; tag 'breaks-without-version', $part_d_orig if ($field eq 'breaks' && !$d_version->[0] && !$VIRTUAL_PACKAGES->known($d_pkg) && !$replaces->implies($part_d_orig) ); tag 'conflicts-with-version', $part_d_orig if ($field eq 'conflicts' && $d_version->[0]); tag 'obsolete-relation-form', "$field: $part_d_orig" if ($d_version && grep { $d_version->[0] eq $_ } ('<', '>')); tag 'bad-version-in-relation', "$field: $part_d_orig" if ($d_version->[0] && ! version_check($d_version->[1])); tag 'package-relation-with-self', "$field: $part_d_orig" if ($pkg eq $d_pkg) && ($field ne 'conflicts' && $field ne 'replaces' && $field ne 'provides'); tag 'bad-relation', "$field: $part_d_orig" if $rest; push @seen_obsolete_packages, $part_d_orig if ($OBSOLETE_PACKAGES->known($d_pkg) && &$is_dep_field($field)); tag 'depends-on-metapackage', "$field: $part_d_orig" if ($KNOWN_METAPACKAGES->known($d_pkg) and not $metapackage and &$is_dep_field($field)); # diffutils is a special case since diff was # renamed to diffutils, so a dependency on # diffutils effectively is a versioned one. tag 'depends-on-essential-package-without-using-version', "$field: $part_d_orig" if ($KNOWN_ESSENTIAL->known($d_pkg) && ! $d_version->[0] && &$is_dep_field($field) && $d_pkg ne 'diffutils' && $d_pkg ne 'dash'); tag 'package-depends-on-an-x-font-package', "$field: $part_d_orig" if ($field =~ /^(pre-)?depends$/ && $d_pkg =~ /^xfont.*/ && $d_pkg ne 'xfonts-utils' && $d_pkg ne 'xfonts-encodings'); tag 'depends-on-packaging-dev', $field if (($field =~ /^(?:pre-)?depends$/ || $field eq 'recommends') && $d_pkg eq 'packaging-dev'); tag 'needlessly-depends-on-awk', $field if ($d_pkg eq 'awk' && ! $d_version->[0] && &$is_dep_field($field) && $pkg ne 'base-files'); tag 'depends-on-libdb1-compat', $field if ($d_pkg eq 'libdb1-compat' && $pkg !~ /^libc(?:6|6.1|0.3)/ && $field =~ m/^(?:pre-)?depends$/o); tag 'depends-on-python-minimal', $field, if ($d_pkg =~ /^python[\d.]*-minimal$/ && &$is_dep_field($field) && $pkg !~ /^python[\d.]*-minimal$/); tag 'doc-package-depends-on-main-package', $field if ("$d_pkg-doc" eq $pkg && $field =~ /^(?:pre-)?depends$/); # only trigger this for the the preferred alternative tag 'versioned-dependency-satisfied-by-perl', "$field: $part_d_orig" if $alternatives[0][-1] eq $part_d_orig && &$is_dep_field($field) && perl_core_has_version($d_pkg, $d_version->[0], $d_version->[1]); tag 'depends-exclusively-on-makedev', $field, if ($field eq 'depends' && $d_pkg eq 'makedev' && @alternatives == 1); tag 'lib-recommends-documentation', "$field: $part_d_orig" if ($field eq 'recommends' && $pkg =~ m/^lib/ && $pkg !~ m/-(?:dev|docs?|tools|bin)$/ && $part_d_orig =~ m/-docs?$/); # default-jdk-doc must depend on openjdk-X-doc (or classpath-doc) to be # useful; other packages should depend on default-jdk-doc if they # want the Java Core API. tag 'depends-on-specific-java-doc-package', $field if(&$is_dep_field($field) && $pkg ne 'default-jdk-doc' && ($d_pkg eq 'classpath-doc' || $d_pkg =~ m/openjdk-\d+-doc/o)); if($javalib && $field eq 'depends'){ foreach my $reg (@known_java_pkg){ if($d_pkg =~ m/$reg/){ $javadep++; last; } } } } for my $pkg (@seen_obsolete_packages) { if ($pkg eq $alternatives[0]->[0] or scalar @seen_obsolete_packages == scalar @alternatives) { tag 'depends-on-obsolete-package', "$field: $pkg"; } else { tag 'ored-depends-on-obsolete-package', "$field: $pkg"; } } # Only emit the tag if all the alternatives are JVM/JRE/JDKs # - assume that | openjdk-6-jre-headless makes sense for now. if (scalar(@alternatives) == $javadep && !exists $nag_once{'needless-dependency-on-jre'}){ $nag_once{'needless-dependency-on-jre'} = 1; tag 'needless-dependency-on-jre' } } tag 'package-depends-on-multiple-libstdc-versions', @seen_libstdcs if (scalar @seen_libstdcs > 1); tag 'package-depends-on-multiple-tcl-versions', @seen_tcls if (scalar @seen_tcls > 1); tag 'package-depends-on-multiple-tclx-versions', @seen_tclxs if (scalar @seen_tclxs > 1); tag 'package-depends-on-multiple-tk-versions', @seen_tks if (scalar @seen_tks > 1); tag 'package-depends-on-multiple-tkx-versions', @seen_tkxs if (scalar @seen_tkxs > 1); tag 'package-depends-on-multiple-libpng-versions', @seen_libpngs if (scalar @seen_libpngs > 1); } # If Conflicts or Breaks is set, make sure it's not inconsistent with # the other dependency fields. for my $conflict (qw/conflicts breaks/) { next unless $fields{$conflict}; for my $field (qw(depends pre-depends recommends suggests)) { next unless $info->field($field); my $relation = $info->relation($field); for my $package (split /\s*,\s*/, $fields{$conflict}) { tag 'conflicts-with-dependency', $field, $package if $relation->implies($package); } } } } #---- Package relations (source package) if ($type eq 'source') { my $binpkgs = $info->binaries; #Get number of arch-indep packages: my $arch_indep_packages = 0; my $arch_dep_packages = 0; foreach my $binpkg (keys %$binpkgs) { my $arch = $info->binary_field($binpkg, 'architecture')//''; if ($arch eq 'all') { $arch_indep_packages++; } else { $arch_dep_packages++; } } tag 'build-depends-indep-without-arch-indep' if (defined $info->field('build-depends-indep') && $arch_indep_packages == 0); my $is_dep_field = sub { grep { $_ eq $_[0] } qw(build-depends build-depends-indep) }; my %depend; for my $field (qw(build-depends build-depends-indep build-conflicts build-conflicts-indep)) { if (defined $info->field($field)) { #Get data and clean it my $data = $info->field($field);; unfold($field, \$data); $depend{$field} = $data; for my $dep (split /\s*,\s*/, $data) { my (@alternatives, @seen_obsolete_packages); push @alternatives, [_split_dep($_), $_] for (split /\s*\|\s*/, $dep); tag 'virtual-package-depends-without-real-package-depends', "$field: $alternatives[0]->[0]" if ($VIRTUAL_PACKAGES->known($alternatives[0]->[0]) && &$is_dep_field($field)); for my $part_d (@alternatives) { my ($d_pkg, $d_version, $d_arch, $rest, $part_d_orig) = @$part_d; my $negated = 0; for my $arch (@{$d_arch->[0]}) { if ($arch eq 'all' || !is_arch_or_wildcard ($arch)) { tag 'invalid-arch-string-in-source-relation', "$arch [$field: $part_d_orig]" } } if ($d_pkg =~ m/^openjdk-\d+-doc$/o or $d_pkg eq 'classpath-doc'){ tag 'build-depends-on-specific-java-doc-package', $d_pkg; } if ($d_pkg =~ m/^libdb\d+\.\d+.*-dev$/o and &$is_dep_field($field)) { tag 'build-depends-on-versioned-berkeley-db', "$field:$d_pkg"; } tag 'conflicting-negation-in-source-relation', "$field: $part_d_orig" unless (not $d_arch or $d_arch->[1] == 0 or $d_arch->[1] eq @{ $d_arch->[0] }); tag 'depends-on-packaging-dev', $field if ($d_pkg eq 'packaging-dev'); tag 'build-depends-on-build-essential', $field if ($d_pkg eq 'build-essential'); tag 'depends-on-build-essential-package-without-using-version', "$d_pkg [$field: $part_d_orig]" if ($known_build_essential->known($d_pkg) && ! $d_version->[1]); tag 'build-depends-on-essential-package-without-using-version', "$field: $part_d_orig" if ($KNOWN_ESSENTIAL->known($d_pkg) && ! $d_version->[0] && $d_pkg ne 'dash'); push @seen_obsolete_packages, $part_d_orig if ($OBSOLETE_PACKAGES->known($d_pkg) && &$is_dep_field($field)); tag 'build-depends-on-metapackage', "$field: $part_d_orig" if ($KNOWN_METAPACKAGES->known($d_pkg) and &$is_dep_field($field)); tag 'build-depends-on-non-build-package', "$field: $part_d_orig" if ($NO_BUILD_DEPENDS->known($d_pkg) and &$is_dep_field($field)); tag 'build-depends-on-1-revision', "$field: $part_d_orig" if ($d_version->[0] eq '>=' && $d_version->[1] =~ /-1$/ && &$is_dep_field($field)); tag 'bad-relation', "$field: $part_d_orig" if $rest; # only trigger this for the the preferred alternative tag 'versioned-dependency-satisfied-by-perl', "$field: $part_d_orig" if $alternatives[0][-1] eq $part_d_orig && &$is_dep_field($field) && perl_core_has_version($d_pkg, $d_version->[0], $d_version->[1]); } for my $pkg (@seen_obsolete_packages) { if ($pkg eq $alternatives[0]->[0] or scalar @seen_obsolete_packages == scalar @alternatives) { tag 'build-depends-on-obsolete-package', "$field: $pkg"; } else { tag 'ored-build-depends-on-obsolete-package', "$field: $pkg"; } } } } } # Check for duplicates. my $build_all = $info->relation('build-depends-all'); my @dups = $build_all->duplicates; for my $dup (@dups) { tag 'package-has-a-duplicate-build-relation', join (', ', @$dup); } # Make sure build dependencies and conflicts are consistent. my %parsed; for ($depend{'build-conflicts'}, $depend{'build-conflicts-indep'}) { next unless $_; for my $conflict (split /\s*,\s*/, $_) { if ($build_all->implies($conflict)) { tag 'build-conflicts-with-build-dependency', $conflict; } } } my (@arch_dep_pkgs, @dbg_pkgs); foreach my $binpkg (keys %$binpkgs) { if ($binpkg =~ m/-dbg$/) { push @dbg_pkgs, $binpkg; } elsif (($info->binary_field($binpkg, 'architecture')//'') ne 'all') { push @arch_dep_pkgs, $binpkg; } } foreach (@dbg_pkgs) { my $deps; $deps = ($info->binary_field($_, 'pre-depends')//'') . ', '; $deps .= $info->binary_field($_, 'depends'); tag 'dbg-package-missing-depends', $_ unless (grep {my $quoted_name = qr<\Q$_>; $deps =~ m/(?:\s|,|^)$quoted_name(?:\s|,|\z)/} @arch_dep_pkgs); } # Check for a python*-dev build dependency in source packages that # build only arch: all packages. if ($arch_dep_packages == 0 and $build_all->implies($PYTHON_DEV)) { tag 'build-depends-on-python-dev-with-no-arch-any'; } } #----- Origin if (defined $info->field('origin')) { my $origin = $info->field('origin'); unfold('origin', \$origin); tag 'redundant-origin-field' if lc($origin) eq 'debian'; } #----- Bugs if (defined $info->field('bugs')) { my $bugs = $info->field('bugs'); unfold('bugs', \$bugs); tag 'redundant-bugs-field' if $bugs =~ m,^debbugs://bugs.debian.org/?$,i; } #----- Python-Version if (defined $info->field('python-version')) { my $pyversion = $info->field('python-version'); unfold('python-version', \$pyversion); my @valid = ([ '\d+\.\d+', '\d+\.\d+' ], [ '\d+\.\d+' ], [ '\>=\s*\d+\.\d+', '\<\<\s*\d+\.\d+' ], [ '\>=\s*\d+\.\d+' ], [ 'current', '\>=\s*\d+\.\d+' ], [ 'current' ], [ 'all' ]); my @pyversion = split(/\s*,\s*/, $pyversion); if (@pyversion > 2) { if (grep { !/^\d+\.\d+$/ } @pyversion) { tag 'malformed-python-version', $pyversion; } } else { my $okay = 0; for my $rule (@valid) { if ($pyversion[0] =~ /^$rule->[0]$/ && (($pyversion[1] && $rule->[1] && $pyversion[1] =~ /^$rule->[1]$/) || (! $pyversion[1] && ! $rule->[1]))) { $okay = 1; last; } } tag 'malformed-python-version', $pyversion unless $okay; } } #----- Dm-Upload-Allowed if (defined $info->field('dm-upload-allowed')) { my $dmupload = $info->field('dm-upload-allowed'); unfold('dm-upload-allowed', \$dmupload); unless ($dmupload eq 'yes') { tag 'malformed-dm-upload-allowed', $dmupload; } } #----- Vcs-* while (my ($vcs, $regex) = each %VCS_RECOMMENDED_URIS) { if (defined $info->field("vcs-$vcs")) { my $uri = $info->field("vcs-$vcs"); unfold("vcs-$vcs", \$uri); if ($uri !~ $regex) { if ($VCS_VALID_URIS{$vcs} and $uri =~ $VCS_VALID_URIS{$vcs}) { tag 'vcs-field-uses-not-recommended-uri-format', "vcs-$vcs", $uri; } else { tag 'vcs-field-uses-unknown-uri-format', "vcs-$vcs", $uri; } } } } #----- Field checks (without checking the value) for my $field (keys %{$info->field}) { next if ($field eq 'original-maintainer') and $version =~ /ubuntu/; tag 'obsolete-field', $field if $known_obsolete_fields{$field}; tag 'unknown-field-in-dsc', $field if ($type eq 'source' && ! $SOURCE_FIELDS->known($field) && ! $known_obsolete_fields{$field}); tag 'unknown-field-in-control', $field if ($type eq 'binary' && ! $KNOWN_BINARY_FIELDS->known($field) && ! $known_obsolete_fields{$field}); tag 'unknown-field-in-control', $field if ($type eq 'udeb' && ! $KNOWN_UDEB_FIELDS->known($field) && ! $known_obsolete_fields{$field}); } } # splits "foo (>= 1.2.3) [!i386 ia64]" into # ( "foo", [ ">=", "1.2.3" ], [ [ "i386", "ia64" ], 1 ], "" ) # ^^^ ^^ # count of negated arches, if ! was given || # rest (should always be "" for valid dependencies) sub _split_dep { my $dep = shift; my ($pkg, $version, $darch) = ('', ['',''], [[], 0]); $pkg = $1 if $dep =~ s/^\s*([^\s\[\(]+)\s*//; if (length $dep) { if ($dep =~ s/\s* \( \s* (<<|<=|<|=|>=|>>|>) \s* ([^\s(]+) \s* \) \s*//x) { @$version = ($1, $2); } if ($dep && $dep =~ s/\s*\[([^\]]+)\]\s*//) { my $t = $1; $darch->[0] = [ split /\s+/, $t ]; my $negated = 0; for my $arch (@{ $darch->[0] }) { $negated++ if $arch =~ s/^!//; } $darch->[1] = $negated; } } return ($pkg, $version, $darch, $dep); } sub perl_core_has_version { my ($package, $op, $version) = @_; my $core_version = $PERL_CORE_PROVIDES->value($package); return 0 if !defined $core_version; return 0 unless version_check($version); return versions_compare($core_version, $op, $version); } sub unfold { my $field = shift; my $line = shift; $$line =~ s/\n$//; if ($$line =~ s/\n//g) { tag 'multiline-field', $field; # Remove leading space as it confuses some of the other checks # that are anchored. This happens if the field starts with a # space and a newline, i.e ($ marks line end): # # Vcs-Browser: $ # http://somewhere.com/$ $$line=~s/^\s*+//; } } 1; # Local Variables: # indent-tabs-mode: nil # cperl-indent-level: 4 # End: # vim: syntax=perl sw=4 sts=4 sr et