vcs.maemo.org Git - maemian/blob - nokia-lintian/checks/fields

   1 # fields -- lintian check script (rewrite) -*- perl -*-
   2 #
   3 # Copyright (C) 2004 Marc Brockschmidt
   4 #
   5 # Parts of the code were taken from the old check script, which
   6 # was Copyright (C) 1998 Richard Braakman (also licensed under the
   7 # GPL 2 or higher)
   8 #
   9 # This program is free software; you can redistribute it and/or modify
  10 # it under the terms of the GNU General Public License as published by
  11 # the Free Software Foundation; either version 2 of the License, or
  12 # (at your option) any later version.
  13 #
  14 # This program is distributed in the hope that it will be useful,
  15 # but WITHOUT ANY WARRANTY; without even the implied warranty of
  16 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  17 # GNU General Public License for more details.
  18 #
  19 # You should have received a copy of the GNU General Public License
  20 # along with this program.  If not, you can find it on the World Wide
  21 # Web at http://www.gnu.org/copyleft/gpl.html, or write to the Free
  22 # Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
  23 # MA 02110-1301, USA.
  24
  25 package Lintian::fields;
  26 use strict;
  27
  28 use lib "$ENV{'LINTIAN_ROOT'}/checks/";
  29 use common_data;
  30 use Dep;
  31 use Tags;
  32 use Util;
  33 use Lintian::Data;
  34
  35 # The allowed Python dependencies currently.  This is the list of alternatives
  36 # that, either directly or through transitive dependencies that can be relied
  37 # upon, ensure /usr/bin/python will exist for the use of dh_python.
  38 my $python_depend = 'python | python-dev | python-all | python-all-dev | '
  39     . join (' | ', map { "python$_ | python$_-dev" } qw(2.4 2.5));
  40
  41 # Certain build tools must be listed in Build-Depends even if there are no
  42 # arch-specific packages because they're required in order to run the clean
  43 # rule.  (See Policy 7.6.)  The following is a list of package dependencies;
  44 # regular expressions that, if they match anywhere in the debian/rules file,
  45 # say that this package is allowed (and required) in Build-Depends; and
  46 # optional tags to use for reporting the problem if some information other
  47 # than the default is required.
  48 my @global_clean_depends = (
  49         [ ant => '^include\s*/usr/share/cdbs/1/rules/ant.mk' ],
  50         [ cdbs => '^include\s+/usr/share/cdbs/' ],
  51         [ dbs => '^include\s+/usr/share/dbs/' ],
  52         [ debhelper => '^include\s+/usr/share/cdbs/1/rules/debhelper.mk' ],
  53         [ dpatch => '^include\s+/usr/share/cdbs/1/rules/dpatch.mk' ],
  54         [ quilt => '^include\s+/usr/share/cdbs/1/rules/patchsys-quilt.mk' ],
  55         [ dpatch => '^include\s+/usr/share/dpatch/' ],
  56         [ quilt => '^include\s+/usr/share/quilt/' ],
  57         [ $python_depend => '/usr/share/cdbs/1/class/python-distutils.mk', 'missing-python-build-dependency' ],
  58 );
  59
  60 # These are similar, but the resulting dependency is only allowed, not
  61 # required.
  62 #
  63 # The xsfclean rule is specific to the packages maintained by the X Strike
  64 # Force, but there are enough of those to make the rule worthwhile.
  65 my @global_clean_allowed = (
  66         [ patchutils => '^include\s+/usr/share/cdbs/1/rules/dpatch.mk' ],
  67         [ patchutils => '^include\s+/usr/share/cdbs/1/rules/patchsys-quilt.mk' ],
  68         [ patchutils => '^include\s+/usr/share/cdbs/1/rules/simple-patchsys.mk' ],
  69         [ 'python-central' => '^DEB_PYTHON_SYSTEM\s*:?=\s*pycentral' ],
  70         [ 'python-support' => '^DEB_PYTHON_SYSTEM\s*:?=\s*pysupport' ],
  71         [ 'python-setuptools' => '/usr/share/cdbs/1/class/python-distutils.mk' ],
  72         [ quilt => '^clean:\s+xsfclean\b' ],
  73 );
  74
  75 # A list of packages; regular expressions that, if they match anywhere in the
  76 # debian/rules file, this package must be listed in either Build-Depends or
  77 # Build-Depends-Indep as appropriate; and optional tags as above.
  78 my @global_depends = (
  79         [ $python_depend => '^\t\s*dh_python\s', 'missing-dh_python-build-dependency' ],
  80         [ 'python-central' => '^\t\s*dh_pycentral\s' ],
  81         [ 'python-support' => '^\t\s*dh_pysupport\s' ],
  82         [ 'python-central' => '^DEB_PYTHON_SYSTEM\s*:?=\s*pycentral' ],
  83         [ 'python-support' => '^DEB_PYTHON_SYSTEM\s*:?=\s*pysupport' ],
  84 );
  85
  86 # Similarly, this list of packages, regexes, and optional tags say that if the
  87 # regex matches in one of clean, build-arch, binary-arch, or a rule they
  88 # depend on, this package is allowed (and required) in Build-Depends.
  89 my @rule_clean_depends = (
  90         [ debhelper => '^\t\s*dh_.+' ],
  91         [ dpatch => '^\t\s*dpatch\s' ],
  92         [ 'libmodule-build-perl' => '(^\t|\|\|)\s*(perl|\$\(PERL\))\s+Build\b' ],
  93         [ "po-debconf" => '^\t\s*debconf-updatepo\s' ],
  94         [ $python_depend => '^\t\s*python\s', 'missing-python-build-dependency' ],
  95         [ $python_depend => '\ssetup\.py\b', 'missing-python-build-dependency' ],
  96         [ quilt => '^\t\s*(\S+=\S+\s+)*quilt\s' ],
  97         [ yada => '^\t\s*yada\s' ],
  98 );
  99
 100 # Similar, but the resulting dependency is only allowed, not required.  We
 101 # permit a versioned dependency on perl-base because that used to be the
 102 # standard suggested dependency.  No package should be depending on just
 103 # perl-base, since it's Priority: required.
 104 my @rule_clean_allowed = (
 105         [ patch => '^\t\s*(?:perl debian/)?yada\s+unpatch' ],
 106         [ 'perl | perl-base (>= 5.6.0-16)' => '(^\t|\|\|)\s*(perl|\$\(PERL\))\s' ],
 107         [ 'python-setuptools' => '\ssetup\.py\b' ],
 108 );
 109
 110 # A simple list of regular expressions which, if they match anywhere in
 111 # debian/rules, indicate the requirements for debian/rules clean are complex
 112 # enough that we can't know what packages are permitted in Build-Depends and
 113 # should bypass the build-depends-without-arch-dep check completely.
 114 my @global_clean_bypass = (
 115         '^include\s*/usr/share/cdbs/1/class/ant.mk',
 116         '^\s+dh\s+'
 117 );
 118
 119 sub run {
 120
 121 my $pkg = shift;
 122 my $type = shift;
 123 my $version;
 124 my $arch_indep;
 125
 126 # Load obsolete packages list.
 127 my $obsolete_packages = Lintian::Data->new ('fields/obsolete-packages');
 128
 129 local $/ = undef; #Read everything in one go
 130
 131 unless (-d "fields") {
 132         fail("directory in lintian laboratory for $type package $pkg missing: fields");
 133 }
 134
 135 #---- Package
 136
 137 if ($type eq "binary"){
 138         if (not open (FH, '<', "fields/package")) {
 139                 tag "no-package-name", "";
 140         } else {
 141                 my $name = <FH>;
 142                 close FH;
 143
 144                 unfold("package", \$name);
 145                 tag "bad-package-name", "" unless $name =~ /^[A-Z0-9][-+\.A-Z0-9]+$/i;
 146                 tag "package-not-lowercase", "" if ($name =~ /[A-Z]/)
 147         }
 148 }
 149
 150 #---- Version
 151
 152 if (not open (FH, '<', "fields/version")) {
 153         tag "no-version-field", "";
 154 } else {
 155         $version = <FH>;
 156         close FH;
 157
 158         unfold("version", \$version);
 159
 160         if (@_ = _valid_version($version)) {
 161                 my ($epoch, $upstream, $debian) = @_;
 162                 if ($upstream !~ /^\d/i) {
 163                         tag "upstream-version-not-numeric", "$version";
 164                 }
 165                 if (defined $debian) {
 166                         tag "debian-revision-should-not-be-zero", "$version"
 167                                 if $debian eq '-0';
 168                         my $ubuntu;
 169                         $debian =~ /^-([^.]+)(?:\.[^.]+)?(?:\.[^.]+)?(\..*)?$/;
 170                         my $extra = $2;
 171                         if (defined $extra) {
 172                                 $debian =~ /^-([^.]+ubuntu[^.]+)(?:\.\d+){1,3}(\..*)?$/;
 173                                 $ubuntu = 1;
 174                                 $extra = $2;
 175                         }
 176                         if (not defined $1 or defined $extra) {
 177                                 tag "debian-revision-not-well-formed", "$version";
 178                         }
 179                         if ($debian =~ /^-[^.-]+\.[^.-]+\./ and not $ubuntu) {
 180                                 tag "binary-nmu-uses-old-version-style", "$version"
 181                                         if $type eq 'binary';
 182                                 tag "binary-nmu-debian-revision-in-source", "$version"
 183                                         if $type eq 'source';
 184                         }
 185                 }
 186                 if ($version =~ /\+b\d+$/ && $type eq "source") {
 187                         tag "binary-nmu-debian-revision-in-source", "$version";
 188                 }
 189         } else {
 190                 tag "bad-version-number", "$version";
 191         }
 192 }
 193
 194 #---- Architecture
 195
 196 if (not open (FH, '<', "fields/architecture")) {
 197         tag "no-architecture-field", "";
 198 } else {
 199         my $archs = <FH>;
 200         close FH;
 201
 202         unfold("architecture", \$archs);
 203
 204         my @archs = split / /, $archs;
 205
 206         if (@archs > 1 && grep { $_ eq "any" || $_ eq "all" } @archs) {
 207                 tag "magic-arch-in-arch-list", "";
 208         }
 209
 210         for my $arch (@archs) {
 211                 tag "unknown-architecture", "$arch" unless $known_archs{$arch};
 212         }
 213
 214         if ($type eq "binary") {
 215                 tag "too-many-architectures", "" if (@archs > 1);
 216                 tag "arch-any-in-binary-pkg", "" if (grep { $_ eq "any" } @archs);
 217                 tag "aspell-package-not-arch-all", ""
 218                     if ($pkg =~ /^aspell-[a-z]{2}(-.*)?$/ && (@archs > 1 || $archs[0] ne 'all'));
 219         }
 220
 221         # Used for later tests.
 222         $arch_indep = 1 if (@archs == 1 && $archs[0] eq 'all');
 223 }
 224
 225 #---- Subarchitecture (udeb)
 226
 227 if (open(FH, '<', "fields/subarchitecture")) {
 228         my $subarch = <FH>;
 229         close(FH);
 230
 231         unfold("subarchitecture", \$subarch);
 232 }
 233
 234 #---- Maintainer
 235 #---- Uploaders
 236
 237 for my $f (qw(maintainer uploaders)) {
 238         if (not open (FH, '<', "fields/$f")) {
 239                 tag "no-maintainer-field", "" if $f eq "maintainer";
 240         } else {
 241                 my $maintainer = <FH>;
 242                 close FH;
 243
 244                 # Note, not expected to hit on uploaders anymore, as dpkg now strips
 245                 # newlines for the .dsc, and the newlines don't hurt in debian/control
 246                 unfold($f, \$maintainer);
 247
 248                 $maintainer =~ s/^\s*(.+?)\s*$/$1/; #Remove leading and trailing whitespace
 249
 250                 if ($f eq "uploaders") {
 251                         check_maint($_, "uploader") for (split /\s*,\s*/, $maintainer);
 252                 } else {
 253                         check_maint($maintainer, $f);
 254                         if ($type eq 'source'
 255                             && $maintainer =~ /\@lists(\.alioth)?\.debian\.org\b/
 256                             && ! -f 'fields/uploaders') {
 257                                 tag 'no-human-maintainers';
 258                         }
 259                 }
 260         }
 261 }
 262
 263 #---- Source
 264
 265 if ($type eq "source") {
 266         if (not open (FH, '<', "fields/source")) {
 267                 tag "no-source-field", "";
 268         } else {
 269                 my $source = <FH>;
 270                 close FH;
 271
 272                 unfold("source", \$source);
 273
 274                 if ($type eq 'source') {
 275                         if ($source ne $pkg) {
 276                                 tag "source-field-does-not-match-pkg-name", "$_";
 277                         }
 278                 } else {
 279                         if ($source !~ /[A-Z0-9][-+\.A-Z0-9]+                      #Package name
 280                                         \s*
 281                                         (?:\((?:\d+:)?(?:[-\.+:A-Z0-9]+?)(?:-[\.+A-Z0-9]+)?\))?\s*$/ix) { #Version
 282                                 tag "source-field-malformed", "$source";
 283                         }
 284                 }
 285         }
 286 }
 287
 288 #---- Essential
 289
 290 if (open (FH, '<', "fields/essential")) {
 291         my $essential = <FH>;
 292         close FH;
 293
 294         unfold("essential", \$essential);
 295
 296         tag "essential-in-source-package", "" if ($type eq "source");
 297         tag "essential-no-not-needed", "" if ($essential eq "no");
 298         tag "unknown-essential-value", "" if ($essential ne "no" and $essential ne "yes");
 299         tag "new-essential-package", "" if ($essential eq "yes" and ! $known_essential{$pkg});
 300 }
 301
 302 #---- Section
 303
 304 if (not open (FH, '<', "fields/section")) {
 305         tag 'no-section-field' if ($type eq 'binary');
 306 } else {
 307         my $section = <FH>;
 308         close FH;
 309
 310         unfold("section", \$section);
 311
 312         if ($type eq 'udeb') {
 313             unless ($section eq 'debian-installer') {
 314                 tag "wrong-section-for-udeb", "$section";
 315             }
 316         } else {
 317             my @parts = split /\//, $section, 2;
 318
 319             if ($parts[0] =~ /non-US/i) {
 320                 tag "non-us-spelling", "" if ($parts[0] ne "non-US");
 321                 if ($parts[1] and not $known_non_us_parts{$parts[1]}) {
 322                     tag "unknown-section", "$section";
 323                 }
 324             } elsif (scalar @parts > 1) {
 325                 tag "unknown-section", "$section" unless $known_archive_parts{$parts[0]};
 326                 tag "unknown-section", "$section" unless $known_sections{$parts[1]};
 327             } elsif ($parts[0] eq 'unknown') {
 328                 tag "section-is-dh_make-template";
 329             } else {
 330                 tag "unknown-section", "$section" unless $known_sections{$parts[0]};
 331             }
 332
 333             # Check package name <-> section.
 334             if ($pkg =~ /-docs?$/) {
 335                 tag "doc-package-should-be-section-doc", $pkg
 336                     unless $parts[-1] eq 'doc';
 337             } elsif ($pkg =~ /^lib.*-perl$/) {
 338                 tag "perl-package-should-be-section-perl", $pkg
 339                     unless $parts[-1] eq 'perl';
 340             } elsif ($pkg =~ /^python-/) {
 341                 tag "python-package-should-be-section-python", $pkg
 342                     unless $parts[-1] eq 'python';
 343             } elsif ($pkg =~ /^lib.*-dev$/) {
 344                 tag "dev-package-should-be-section-libdevel", $pkg
 345                     unless $parts[-1] eq 'libdevel';
 346             }
 347         }
 348 }
 349
 350 #---- Priority
 351
 352 if (not open (FH, '<', "fields/priority")) {
 353         tag "no-priority-field", "" if $type eq "binary";
 354 } else {
 355         my $priority = <FH>;
 356         close FH;
 357
 358         unfold("priority", \$priority);
 359
 360         tag "unknown-priority", "$priority" if (! $known_prios{$priority});
 361
 362         if ($pkg =~ /-dbg$/) {
 363                 tag "debug-package-should-be-priority-extra", $pkg
 364                     unless $priority eq 'extra';
 365         }
 366 }
 367
 368 #---- Standards-Version
 369 # handled in checks/standards-version
 370
 371 #---- Description
 372 # handled in checks/description
 373
 374 #--- Homepage
 375
 376 if (open (FH, '<', "fields/homepage")) {
 377         my $homepage = <FH>;
 378         close(FH);
 379
 380         unfold("homepage", \$homepage);
 381
 382         if ($homepage =~ /^\s*<(?:UR[LI]:)?.*>\s*$/i) {
 383                 tag "superfluous-clutter-in-homepage", $homepage;
 384         }
 385
 386         require URI;
 387         my $uri = URI->new($homepage);
 388
 389         unless ($uri->scheme) { # not an absolute URI
 390                 tag "bad-homepage", $homepage;
 391         }
 392 }
 393
 394 #---- Installer-Menu-Item (udeb)
 395
 396 if (open(FH, '<', "fields/installer-menu-item")) {
 397         my $menu_item = <FH>;
 398         close(FH);
 399
 400         unfold('installer-menu-item', \$menu_item);
 401
 402         $menu_item =~ /^\d+$/ or tag "bad-menu-item", "$menu_item";
 403 }
 404
 405
 406 #---- Package relations (binary package)
 407
 408 # Check whether the package looks like a meta-package, used for later
 409 # dependency checks.  We consider a package to possibly be a meta-package if
 410 # it is a binary package, arch: all, with no files outside of /usr/share/doc.
 411 my $metapackage = 0;
 412 if ($type eq 'binary' && $arch_indep) {
 413         $metapackage = 1;
 414         open (IN, '<', "index") or fail("cannot open index file index: $!");
 415         local $_;
 416         local $/ = "\n";
 417         while (<IN>) {
 418                 my ($mode, $file) = (split(' ', $_, 6))[0,5];
 419                 next unless $file;
 420                 $metapackage = 0 unless ($mode =~ /^d/ || $file =~ m%^\./usr/share/doc/%);
 421         }
 422         close IN;
 423 }
 424 if (($type eq "binary") || ($type eq 'udeb')) {
 425         my (%deps, %fields, %parsed);
 426         my $debugpackage = 0;
 427         my ($debugbase, $debugfound);
 428         if ($pkg =~ /^([^-]+)(?:-.*)?-dbg$/) {
 429                 $debugpackage = 1;
 430                 $debugbase = $1;
 431         }
 432         for my $field (qw(depends pre-depends recommends suggests conflicts provides replaces breaks)) {
 433                 if (open(FH, '<', "fields/$field")) {
 434                         #Get data and clean it
 435                         my $data = <FH>;
 436                         unfold($field, \$data);
 437                         $data =~ s/^\s*(.+?)\s*$/$1/;
 438                         $fields{$field} = $data;
 439                         $parsed{$field} = Dep::parse ($data);
 440
 441                         my (@seen_libstdcs, @seen_tcls, @seen_tclxs, @seen_tks, @seen_tkxs, @seen_libpngs);
 442
 443                         my $is_dep_field = sub { grep { $_ eq $_[0] } qw(depends pre-depends recommends suggests) };
 444
 445                         tag "package-uses-breaks" if $field eq "breaks";
 446
 447                         tag "alternates-not-allowed", "$field"
 448                             if ($data =~ /\|/ && ! &$is_dep_field($field));
 449
 450                         for my $dep (split /\s*,\s*/, $data) {
 451                                 my (@alternatives, @seen_obsolete_packages);
 452                                 push @alternatives, [_split_dep($_), $_] for (split /\s*\|\s*/, $dep);
 453
 454                                 if (&$is_dep_field($field)) {
 455                                         push @seen_libstdcs, $alternatives[0]->[0]
 456                                             if defined $known_libstdcs{$alternatives[0]->[0]};
 457                                         push @seen_tcls, $alternatives[0]->[0]
 458                                             if defined $known_tcls{$alternatives[0]->[0]};
 459                                         push @seen_tclxs, $alternatives[0]->[0]
 460                                             if defined $known_tclxs{$alternatives[0]->[0]};
 461                                         push @seen_tks, $alternatives[0]->[0]
 462                                             if defined $known_tks{$alternatives[0]->[0]};
 463                                         push @seen_tkxs, $alternatives[0]->[0]
 464                                             if defined $known_tkxs{$alternatives[0]->[0]};
 465                                         push @seen_libpngs, $alternatives[0]->[0]
 466                                             if defined $known_libpngs{$alternatives[0]->[0]};
 467                                 }
 468
 469                                 # Only for (Pre-)?Depends.
 470                                 tag "virtual-package-depends-without-real-package-depends", "$field: $alternatives[0]->[0]"
 471                                     if ($known_virtual_packages{$alternatives[0]->[0]}
 472                                         && ($field eq "depends" || $field eq "pre-depends"));
 473
 474                                 # Check defaults for transitions.  Here, we only care that the first alternative is current.
 475                                 tag "depends-on-old-emacs", "$field: $alternatives[0]->[0]"
 476                                     if (&$is_dep_field($field) && $known_obsolete_emacs{$alternatives[0]->[0]});
 477
 478                                 for my $part_d (@alternatives) {
 479                                         my ($d_pkg, $d_version, $d_arch, $rest, $part_d_orig) = @$part_d;
 480
 481                                         # We have found a Depends: on our non-dbg equivalent.
 482                                         if ($debugpackage && $field eq "depends" && $d_pkg =~ /^\Q$debugbase/) {
 483                                                 $debugfound = 1;
 484                                         }
 485
 486                                         tag "versioned-provides", "$part_d_orig"
 487                                             if ($field eq "provides" && $d_version->[0]);
 488
 489                                         tag "breaks-without-version", "$part_d_orig"
 490                                             if ($field eq "breaks" && !$d_version->[0]);
 491
 492                                         tag "obsolete-relation-form", "$field: $part_d_orig"
 493                                             if ($d_version && grep { $d_version->[0] eq $_ } ("<", ">"));
 494
 495                                         tag "bad-version-in-relation", "$field: $part_d_orig"
 496                                             if ($d_version->[0] && ! defined((_valid_version($d_version->[1]))[1]));
 497
 498                                         tag "package-relation-with-self", "$field: $part_d_orig"
 499                                             if ($pkg eq $d_pkg) && ($field ne 'conflicts');
 500
 501                                         tag "bad-relation", "$field: $part_d_orig"
 502                                             if $rest;
 503
 504                                         push @seen_obsolete_packages, $part_d_orig
 505                                             if ($obsolete_packages->known($d_pkg) && &$is_dep_field($field));
 506
 507                                         tag "depends-on-x-metapackage", "$field: $part_d_orig"
 508                                             if ($known_x_metapackages{$d_pkg} && ! $metapackage && &$is_dep_field($field));
 509
 510                                         tag "depends-on-essential-package-without-using-version", "$field: $part_d_orig"
 511                                             if ($known_essential{$d_pkg} && ! $d_version->[0] && &$is_dep_field($field));
 512
 513                                         tag "package-depends-on-an-x-font-package", "$field: $part_d_orig"
 514                                             if ($field =~ /^(pre-)?depends$/ && $d_pkg =~ /^xfont.*/ && $d_pkg ne 'xfonts-utils' && $d_pkg ne 'xfongs-encodings');
 515
 516                                         tag "needlessly-depends-on-awk", "$field"
 517                                             if ($d_pkg eq "awk" && ! $d_version->[0] && &$is_dep_field($field));
 518
 519                                         tag "depends-on-libdb1-compat", "$field"
 520                                             if ($d_pkg eq "libdb1-compat" && $pkg !~ /^libc(6|6.1|0.3)/ && $field =~ /^(pre-)depends$/);
 521
 522                                         tag "depends-on-python-minimal", "$field",
 523                                             if ($d_pkg =~ /^python[\d.]*-minimal$/ && &$is_dep_field($field)
 524                                                 && $pkg !~ /^python[\d.]*-minimal$/);
 525
 526                                         tag "doc-package-depends-on-main-package", "$field"
 527                                             if ("$d_pkg-doc" eq $pkg && $field =~ /^(pre-)depends$/);
 528
 529                                         tag "old-versioned-python-dependency", "$field: $part_d_orig"
 530                                             if ($d_pkg eq 'python' && $d_version->[0] eq '<<' && &$is_dep_field($field)
 531                                                 && $arch_indep && $pkg =~ /^python-/ && ! -f "fields/python-version");
 532                                 }
 533
 534                                 for my $pkg (@seen_obsolete_packages) {
 535                                         if ($pkg eq $alternatives[0]->[0] or
 536                                             scalar @seen_obsolete_packages == scalar @alternatives) {
 537                                                 tag "depends-on-obsolete-package", "$field: $pkg";
 538                                         } else {
 539                                                 tag "ored-depends-on-obsolete-package", "$field: $pkg";
 540                                         }
 541                                 }
 542                         }
 543                         tag "package-depends-on-multiple-libstdc-versions", @seen_libstdcs
 544                             if (scalar @seen_libstdcs > 1);
 545                         tag "package-depends-on-multiple-tcl-versions", @seen_tcls
 546                             if (scalar @seen_tcls > 1);
 547                         tag "package-depends-on-multiple-tclx-versions", @seen_tclxs
 548                             if (scalar @seen_tclxs > 1);
 549                         tag "package-depends-on-multiple-tk-versions", @seen_tks
 550                             if (scalar @seen_tks > 1);
 551                         tag "package-depends-on-multiple-tkx-versions", @seen_tkxs
 552                             if (scalar @seen_tkxs > 1);
 553                         tag "package-depends-on-multiple-libpng-versions", @seen_libpngs
 554                             if (scalar @seen_libpngs > 1);
 555                 }
 556         }
 557
 558         tag "dbg-package-missing-depends", $debugbase
 559                 if ($debugpackage && !$debugfound);
 560
 561         # If Conflicts or Breaks is set, make sure it's not inconsistent with
 562         # the other dependency fields.
 563         for my $conflict (qw/conflicts breaks/) {
 564                 next unless $fields{$conflict};
 565                 for my $field (qw(depends pre-depends recommends suggests)) {
 566                         next unless $parsed{$field};
 567                         for my $package (split /\s*,\s*/, $fields{$conflict}) {
 568                                 tag "conflicts-with-dependency", $field, $package
 569                                     if Dep::implies($parsed{$field}, Dep::parse($package));
 570                         }
 571                 }
 572         }
 573 }
 574
 575 #---- Package relations (source package)
 576
 577 if ($type eq "source") {
 578
 579         #Get number of arch-indep packages:
 580         my $arch_indep_packages = 0;
 581         my $arch_dep_packages = 0;
 582         if (not open(CONTROL, '<', "debfiles/control")) {
 583                 fail("Can't open debfiles/control: $!");
 584         } else {
 585                 local $/ = "\n"; #Read this linewise
 586                 while (<CONTROL>) {
 587                         if (/^Architecture: all/) {
 588                                 $arch_indep_packages++;
 589                         } elsif (/^Architecture:/) {
 590                                 $arch_dep_packages++;
 591                         }
 592                 }
 593         }
 594
 595         # Search through rules and determine which dependencies are required.
 596         # The keys in %needed and %needed_clean are the dependencies; the
 597         # values are the tags to use or the empty string to use the default
 598         # tag.
 599         my (%needed, %needed_clean, %allowed_clean, $bypass_needed_clean);
 600         open (RULES, '<', "debfiles/rules")
 601             or fail("cannot read debfiles/rules: $!");
 602         my $target = "none";
 603         local $/ = "\n";        # Read this linewise
 604         my @rules = qw(clean binary-arch build-arch);
 605         my $maybe_skipping;
 606         while (<RULES>) {
 607                 if (/^ifn?(eq|def)\s/) {
 608                         $maybe_skipping++;
 609                 } elsif (/^endif\s/) {
 610                         $maybe_skipping--;
 611                 }
 612                 for my $rule (@global_clean_depends) {
 613                         if ($_ =~ /$rule->[1]/) {
 614                                 if ($maybe_skipping) {
 615                                         $allowed_clean{$rule->[0]} = 1;
 616                                 } else {
 617                                         $needed_clean{$rule->[0]} = $rule->[2] || $needed_clean{$rule->[0]} || '';
 618                                 }
 619                         }
 620                 }
 621                 for my $rule (@global_clean_allowed) {
 622                         if ($_ =~ /$rule->[1]/) {
 623                                 $allowed_clean{$rule->[0]} = 1;
 624                         }
 625                 }
 626                 for my $rule (@global_clean_bypass) {
 627                         if ($_ =~ /$rule/) {
 628                                 $bypass_needed_clean = 1;
 629                         }
 630                 }
 631                 for my $rule (@global_depends) {
 632                         if ($_ =~ /$rule->[1]/ && !$maybe_skipping) {
 633                                 $needed{$rule->[0]} = $rule->[2] || $needed{$rule->[0]} || '';
 634                         }
 635                 }
 636                 if (/^(\S+?):+(.*)/) {
 637                         $target = $1;
 638                         if (grep ($_ eq $target, @rules)) {
 639                                 push (@rules, split (' ', $2));
 640                         }
 641                 }
 642                 if (grep ($_ eq $target, @rules)) {
 643                         for my $rule (@rule_clean_depends) {
 644                                 if ($_ =~ /$rule->[1]/) {
 645                                         if ($maybe_skipping) {
 646                                                 $allowed_clean{$rule->[0]} = 1;
 647                                         } else {
 648                                                 $needed_clean{$rule->[0]} = $rule->[2] || $needed_clean{$rule->[0]} || '';
 649                                         }
 650                                 }
 651                         }
 652                         for my $rule (@rule_clean_allowed) {
 653                                 if ($_ =~ /$rule->[1]/) {
 654                                         $allowed_clean{$rule->[0]} = 1;
 655                                 }
 656                         }
 657                 }
 658         }
 659         close RULES;
 660         $/ = undef;             # Back to reading everything.
 661
 662         tag "build-depends-indep-without-arch-indep", ""
 663                 if (-e "fields/build-depends-indep" && $arch_indep_packages == 0);
 664
 665         my $is_dep_field = sub { grep { $_ eq $_[0] } qw(build-depends build-depends-indep) };
 666
 667         my %depend;
 668         for my $field (qw(build-depends build-depends-indep build-conflicts build-conflicts-indep)) {
 669                 if (open(FH, '<', "fields/$field")) {
 670                         #Get data and clean it
 671                         my $data = <FH>;
 672                         unfold($field, \$data);
 673                         $data =~ s/^\s*(.+?)\s*$/$1/;
 674                         $depend{$field} = $data;
 675
 676                         for my $dep (split /\s*,\s*/, $data) {
 677                                 my @alternatives;
 678                                 push @alternatives, [_split_dep($_), $_] for (split /\s*\|\s*/, $dep);
 679
 680                                 tag "virtual-package-depends-without-real-package-depends", "$field: $alternatives[0]->[0]"
 681                                     if ($known_virtual_packages{$alternatives[0]->[0]} && &$is_dep_field($field));
 682
 683                                 for my $part_d (@alternatives) {
 684                                         my ($d_pkg, $d_version, $d_arch, $rest, $part_d_orig) = @$part_d;
 685
 686                                         for my $arch (@{$d_arch->[0]}) {
 687                                                 if (!$known_archs{$arch}) {
 688                                                         tag "invalid-arch-string-in-source-relation", "$arch [$field: $part_d_orig]"
 689                                                 }
 690                                         }
 691
 692                                         tag "build-depends-on-build-essential", $field
 693                                             if ($d_pkg eq "build-essential");
 694
 695                                         tag "depends-on-build-essential-package-without-using-version", "$d_pkg [$field: $part_d_orig]"
 696                                             if ($known_build_essential{$d_pkg} && ! $d_version->[1]);
 697
 698                                         tag "build-depends-on-essential-package-without-using-version", "$field: $part_d_orig"
 699                                             if ($d_pkg ne "coreutils" && $known_essential{$d_pkg} && ! $d_version->[0]);
 700                                         tag "build-depends-on-obsolete-package", "$field: $part_d_orig"
 701                                             if ($obsolete_packages->known($d_pkg) && &$is_dep_field($field));
 702
 703                                         tag "build-depends-on-x-metapackage", "$field: $part_d_orig"
 704                                             if ($known_x_metapackages{$d_pkg} && &$is_dep_field($field));
 705
 706                                         tag "build-depends-on-1-revision", "$field: $part_d_orig"
 707                                             if ($d_version->[0] eq '>=' && $d_version->[1] =~ /-1$/ && &$is_dep_field($field));
 708
 709                                         tag "bad-relation", "$field: $part_d_orig"
 710                                             if $rest;
 711                                 }
 712                         }
 713                 }
 714         }
 715
 716         # Check for duplicates.
 717         my $build_all = $depend{'build-depends'} || '';
 718         $build_all .= ', ' if $depend{'build-depends'} && $depend{'build-depends-indep'};
 719         $build_all .= $depend{'build-depends-indep'} || '';
 720         my @dups = Dep::get_dups(Dep::parse($build_all));
 721         for my $dup (@dups) {
 722                 tag "package-has-a-duplicate-build-relation", join (', ', @$dup);
 723         }
 724
 725         # Make sure build dependencies and conflicts are consistent.
 726         $depend{'build-depends'} = Dep::parse($depend{'build-depends'} || '');
 727         $depend{'build-depends-indep'} = Dep::parse($depend{'build-depends-indep'} || '');
 728         for ($depend{'build-conflicts'}, $depend{'build-conflicts-indep'}) {
 729                 next unless $_;
 730                 for my $conflict (split /\s*,\s*/, $_) {
 731                         if (Dep::implies($depend{'build-depends'}, Dep::parse($conflict))
 732                             || Dep::implies($depend{'build-depends-indep'}, Dep::parse($conflict))) {
 733                                 tag "build-conflicts-with-build-dependency", $conflict;
 734                         }
 735                 }
 736         }
 737
 738         # Make sure that all the required build dependencies are there.  Don't
 739         # issue missing-build-dependency errors for debhelper, since there's
 740         # another test that does that and it would just be a duplicate.
 741         for my $package (keys %needed_clean) {
 742                 my $dep = Dep::parse($package);
 743                 my $tag = $needed_clean{$package} || 'missing-build-dependency';
 744                 unless (Dep::implies($depend{'build-depends'}, $dep)) {
 745                         if (Dep::implies($depend{'build-depends-indep'}, $dep)) {
 746                                 tag "clean-should-be-satisfied-by-build-depends", $package;
 747                         } else {
 748                                 if ($tag eq 'missing-build-dependency') {
 749                                         tag $tag, $package if $package ne 'debhelper';
 750                                 } else {
 751                                         tag $tag;
 752                                 }
 753                         }
 754                 }
 755         }
 756         for my $package (keys %needed) {
 757                 my $dep = Dep::parse($package);
 758                 my $tag = $needed{$package} || 'missing-build-dependency';
 759
 760                 # dh_python deactivates itself if the new Python build policy
 761                 # is enabled.
 762                 if ($tag eq 'missing-dh_python-build-dependency') {
 763                         next if -f 'debfiles/pycomat';
 764                         next if -f 'fields/python-version';
 765                 }
 766                 unless (Dep::implies($depend{'build-depends'}, $dep)) {
 767                         unless (Dep::implies($depend{'build-depends-indep'}, $dep)) {
 768                                 if ($tag eq 'missing-build-dependency') {
 769                                         tag $tag, $package;
 770                                 } else {
 771                                         tag $tag;
 772                                 }
 773                         }
 774                 }
 775         }
 776
 777         # This check is a bit tricky.  We want to allow in Build-Depends a
 778         # dependency with any version, since reporting this tag over version
 779         # mismatches would be confusing and quite likely wrong.  The approach
 780         # taken is to strip the version information off all dependencies
 781         # allowed in Build-Depends, strip the version information off of the
 782         # dependencies in Build-Depends, and then allow any dependency in
 783         # Build-Depends that's implied by the dependencies we require or allow
 784         # there.
 785         #
 786         # We also have to map | to , when building the list of allowed
 787         # packages so that the implications will work properly.
 788         #
 789         # This is confusing.  There should be a better way to do this.
 790         if (-e "fields/build-depends" && $arch_dep_packages == 0 && !$bypass_needed_clean) {
 791                 open(FH, '<', "fields/build-depends")
 792                     or fail("cannot read fields/build-depends: $!");
 793                 my $build_depends = <FH>;
 794                 close FH;
 795                 my @packages = split /\s*,\s*/, $build_depends;
 796                 my @allowed = map { s/[\(\[][^\)\]]+[\)\]]//g; s/\|/,/g; $_ } keys (%needed_clean), keys (%allowed_clean);
 797                 my $dep = Dep::parse (join (',', @allowed));
 798                 foreach my $pkg (@packages) {
 799                         my $name = $pkg;
 800                         $name =~ s/[\[\(][^\)\]]+[\)\]]//g;
 801                         $name =~ s/\s+$//;
 802                         $name =~ s/\s+/ /g;
 803                         unless (Dep::implies($dep, Dep::parse($name))) {
 804                                 tag "build-depends-without-arch-dep", $name;
 805                         }
 806                 }
 807         }
 808 }
 809
 810 #----- Origin
 811
 812 if (open(FH, '<', "fields/origin")) {
 813         my $origin = <FH>;
 814         close(FH);
 815
 816         unfold('origin', \$origin);
 817
 818         tag "redundant-origin-field", "" if $origin =~ /^\s*debian\s*$/i;
 819 }
 820
 821 #----- Bugs
 822
 823 if (open(FH, '<', "fields/bugs")) {
 824         my $bugs = <FH>;
 825         close FH;
 826
 827         unfold('bugs', \$bugs);
 828
 829         tag "redundant-bugs-field"
 830             if $bugs =~ m,^\s*debbugs://bugs.debian.org/?\s*$,i;
 831 }
 832
 833 #----- Python-Version
 834
 835 if (open(FH, '<', "fields/python-version")) {
 836         my $pyversion = <FH>;
 837         close FH;
 838
 839         unfold('python-version', \$pyversion);
 840
 841         my @valid = ([ '\d+\.\d+', '\d+\.\d+' ],
 842                      [ '\d+\.\d+' ],
 843                      [ '\>=\s*\d+\.\d+', '\<\<\s*\d+\.\d+' ],
 844                      [ '\>=\s*\d+\.\d+' ],
 845                      [ 'current', '\>=\s*\d+\.\d+' ],
 846                      [ 'current' ],
 847                      [ 'all' ]);
 848
 849         my @pyversion = split(/\s*,\s*/, $pyversion);
 850         if (@pyversion > 2) {
 851                 if (grep { !/^\d+\.\d+$/ } @pyversion) {
 852                         tag "malformed-python-version", "$pyversion";
 853                 }
 854         } else {
 855                 my $okay = 0;
 856                 for my $rule (@valid) {
 857                         if ($pyversion[0] =~ /^$rule->[0]$/
 858                             && (($pyversion[1] && $rule->[1] && $pyversion[1] =~ /^$rule->[1]$/)
 859                                  || (! $pyversion[1] && ! $rule->[1]))) {
 860                                 $okay = 1;
 861                                 last;
 862                         }
 863                 }
 864                 tag "malformed-python-version", "$pyversion" unless $okay;
 865         }
 866 }
 867
 868 #----- Dm-Upload-Allowed
 869
 870 if (open(FH, '<', 'fields/dm-upload-allowed')) {
 871         my $dmupload = <FH>;
 872         close FH;
 873
 874         unfold('dm-upload-allowed', \$dmupload);
 875
 876         unless ($dmupload =~ /^\s*yes\s*$/) {
 877                 tag "malformed-dm-upload-allowed", "$dmupload";
 878         }
 879 }
 880
 881 #----- Field checks (without checking the value)
 882
 883 for my $field (glob("fields/*")) {
 884         $field =~ s!^fields/!!;
 885
 886         next if ($field eq 'original-maintainer') and $version =~ /ubuntu/;
 887
 888         tag "obsolete-field", "$field"
 889             if $known_obsolete_fields{$field};
 890
 891         tag "unknown-field-in-dsc", "$field"
 892             if ($type eq "source" && ! $known_source_fields{$field} && ! $known_obsolete_fields{$field});
 893
 894         tag "unknown-field-in-control", "$field"
 895             if ($type eq "binary" && ! $known_binary_fields{$field} && ! $known_obsolete_fields{$field});
 896
 897         tag "unknown-field-in-control", "$field"
 898             if ($type eq "udeb" && ! $known_udeb_fields{$field} && ! $known_obsolete_fields{$field});
 899 }
 900
 901 }
 902
 903 # splits "foo (>= 1.2.3) [!i386 ia64]" into
 904 # ( "foo", [ ">=", "1.2.3" ], [ [ "i386", "ia64" ], 1 ], "" )
 905 #                                                  ^^^   ^^
 906 #                                 true, if ! was given   ||
 907 #           rest (should always be "" for valid dependencies)
 908 sub _split_dep {
 909         my $dep = shift;
 910         my ($pkg, $version, $darch) = ("", ["",""], [[],""]);
 911
 912         $pkg = $1 if $dep =~ s/^\s*([^\s\[\(]+)\s*//;
 913
 914         if (length $dep) {
 915                 if ($dep =~ s/\s* \( \s* (<<|<=|<|=|>=|>>|>) \s* ([^\s(]+) \s* \) \s*//x) {
 916                         @$version = ($1, $2);
 917                 }
 918                 if ($dep && $dep =~ s/\s*\[([^\]]+)\]\s*//) {
 919                         my $t = $1;
 920                         $darch->[1] = 1 if ($t =~ s/!//g);
 921                         $darch->[0] = [ split /\s+/, $t ];
 922                 }
 923         }
 924
 925         return ($pkg, $version, $darch, $dep);
 926 }
 927
 928 sub _valid_version {
 929         my $ver = shift;
 930
 931         # epoch check means nothing here... This check is only useful to detect
 932         # weird characters in version (and to get the debian revision)
 933         if ($ver =~ m/^(\d+:)?([-\.+:~A-Z0-9]+?)(-[\.+~A-Z0-9]+)?$/i) {
 934                 return ($1, $2, $3);
 935         } else {
 936                 return ();
 937         }
 938 }
 939
 940 sub unfold {
 941         my $field = shift;
 942         my $line = shift;
 943
 944         $$line =~ s/\n$//;
 945
 946         if ($$line =~ s/\n//g) {
 947                 tag "multiline-field", "$field";
 948         }
 949 }
 950
 951 sub check_maint {
 952         my ($maintainer, $f) = @_;
 953         $maintainer =~ /^([^<\s]*(?:\s+[^<\s]+)*)?(\s*)(?:<(.+)>)?(.*)$/,
 954         my ($name, $del, $mail, $crap) = ($1, $2, $3, $4);
 955
 956         if (!$mail && $name =~ m/@/) { # name probably missing and address has no <>
 957                 $mail = $name;
 958                 $name = undef;
 959         }
 960
 961         tag "$f-address-malformed", "$maintainer" if $crap;
 962         tag "$f-address-looks-weird", "$maintainer" if ! $del && $name && $mail;
 963
 964         # Wookey really only has one name.  If we get more of these, consider
 965         # removing the check.
 966         if (! $name) {
 967                 tag "$f-name-missing", "$maintainer";
 968         } elsif ($name !~ /^\S+\s+\S+/ && $name ne 'Wookey') {
 969                 tag "$f-not-full-name", "$name";
 970         }
 971
 972         #This should be done with Email::Valid:
 973         if (!$mail) {
 974                 tag "$f-address-missing", "$maintainer";
 975         } else {
 976                 tag "$f-address-malformed", "$maintainer"
 977                     unless ($mail =~ /^[^()<>@,;:\\"[\]]+@(\S+\.)+\S+/); #"
 978
 979                 tag "$f-address-is-on-localhost", "$maintainer"
 980                     if ($mail =~ /(?:localhost|\.localdomain|\.localnet)$/);
 981
 982                 tag "wrong-debian-qa-address-set-as-maintainer", "$maintainer"
 983                     if ($f eq "maintainer" && $mail eq 'debian-qa@lists.debian.org');
 984
 985                 tag "wrong-debian-qa-group-name", "$maintainer"
 986                     if ($f eq "maintainer" && $mail eq 'packages@qa.debian.org' &&
 987                                 $name ne 'Debian QA Group');
 988         }
 989 }
 990
 991 1;
 992
 993 # Local Variables:
 994 # indent-tabs-mode: t
 995 # cperl-indent-level: 8
 996 # End:
 997 # vim: syntax=perl sw=4 ts=4 noet shiftround