vcs.maemo.org Git - maemian/blob - 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 Maemian::fields;
  26 use strict;
  27
  28 use lib "$ENV{'MAEMIAN_ROOT'}/checks/";
  29 use common_data;
  30 use Tags;
  31 use Util;
  32
  33 use Maemian::Data ();
  34 use Maemian::Check qw(check_maintainer);
  35 use Maemian::Relation ();
  36 use Maemian::Relation::Version qw(versions_compare);
  37
  38 our $KNOWN_ARCHS = Maemian::Data->new ('fields/architectures');
  39
  40 our %known_archive_parts = map { $_ => 1 }
  41     ('non-free', 'contrib');
  42
  43 our %known_sections = map { $_ => 1 }
  44     ('admin', 'comm', 'cli-mono', 'database', 'debug', 'devel', 'doc',
  45      'editors', 'electronics', 'embedded', 'fonts', 'games', 'gnome', 'gnu-r',
  46      'gnustep', 'graphics', 'hamradio', 'haskell', 'httpd', 'interpreters',
  47      'java', 'kde', 'libdevel', 'libs', 'lisp', 'localization', 'kernel', 'mail',
  48      'math', 'misc', 'net', 'news', 'ocaml', 'oldlibs', 'otherosfs', 'perl',
  49      'php', 'python', 'ruby', 'science', 'shells', 'sound', 'tex', 'text',
  50      'utils', 'vcs', 'video', 'web', 'x11', 'xfce', 'zope'
  51     );
  52
  53 our %known_prios = map { $_ => 1 }
  54     ('required', 'important', 'standard', 'optional', 'extra');
  55
  56 # The Ubuntu original-maintainer field is handled separately.
  57 our %known_binary_fields = map { $_ => 1 }
  58     ('package', 'version', 'architecture', 'depends', 'pre-depends',
  59      'recommends', 'suggests', 'enhances', 'conflicts', 'provides',
  60      'replaces', 'breaks', 'essential', 'maintainer', 'section', 'priority',
  61      'source', 'description', 'installed-size', 'python-version', 'homepage',
  62      'bugs', 'origin');
  63
  64 # The Ubuntu original-maintainer field is handled separately.
  65 our %known_udeb_fields = map { $_ => 1 }
  66     ('package', 'version', 'architecture', 'subarchitecture', 'depends',
  67      'recommends', 'enhances', 'provides', 'replaces', 'breaks', 'replaces',
  68      'maintainer', 'section', 'priority', 'source', 'description',
  69      'installed-size', 'kernel-version', 'installer-menu-item', 'bugs',
  70      'origin');
  71
  72 our %known_obsolete_fields = map { $_ => 1 }
  73     ('revision', 'package-revision', 'package_revision',
  74      'recommended', 'optional', 'class');
  75
  76 our %known_build_essential = map { $_ => 1 }
  77     ('libc6-dev', 'libc-dev', 'gcc', 'g++', 'make', 'dpkg-dev');
  78
  79 # Still in the archive but shouldn't be the primary Emacs dependency.
  80 our %known_obsolete_emacs = map { $_ => 1 }
  81     ('emacs21');
  82
  83 our %known_libstdcs = map { $_ => 1 }
  84     ('libstdc++2.9-glibc2.1', 'libstdc++2.10', 'libstdc++2.10-glibc2.2',
  85      'libstdc++3', 'libstdc++3.0', 'libstdc++4', 'libstdc++5',
  86      'libstdc++6', 'lib64stdc++6',
  87     );
  88
  89 our %known_tcls = map { $_ => 1 }
  90     ( 'tcl74', 'tcl8.0', 'tcl8.2', 'tcl8.3', 'tcl8.4', 'tcl8.5', );
  91
  92 our %known_tclxs = map { $_ => 1 }
  93     ( 'tclx76', 'tclx8.0.4', 'tclx8.2', 'tclx8.3', 'tclx8.4', );
  94
  95 our %known_tks = map { $_ => 1 }
  96     ( 'tk40', 'tk8.0', 'tk8.2', 'tk8.3', 'tk8.4', 'tk8.5', );
  97
  98 our %known_tkxs = map { $_ => 1 }
  99     ( 'tkx8.2', 'tkx8.3', );
 100
 101 our %known_libpngs = map { $_ => 1 }
 102     ( 'libpng12-0', 'libpng2', 'libpng3', );
 103
 104 our %known_x_metapackages = map { $_ => 1 }
 105     ( 'x-window-system', 'x-window-system-dev', 'x-window-system-core',
 106       'xorg', 'xorg-dev', );
 107
 108 # The allowed Python dependencies currently.  This is the list of alternatives
 109 # that, either directly or through transitive dependencies that can be relied
 110 # upon, ensure /usr/bin/python will exist for the use of dh_python.
 111 our $PYTHON_DEPEND = 'python | python-dev | python-all | python-all-dev | '
 112     . join (' | ', map { "python$_ | python$_-dev" } qw(2.4 2.5));
 113
 114 # Certain build tools must be listed in Build-Depends even if there are no
 115 # arch-specific packages because they're required in order to run the clean
 116 # rule.  (See Policy 7.6.)  The following is a list of package dependencies;
 117 # regular expressions that, if they match anywhere in the debian/rules file,
 118 # say that this package is allowed (and required) in Build-Depends; and
 119 # optional tags to use for reporting the problem if some information other
 120 # than the default is required.
 121 our @GLOBAL_CLEAN_DEPENDS = (
 122         [ ant => qr'^include\s*/usr/share/cdbs/1/rules/ant\.mk' ],
 123         [ cdbs => qr'^include\s+/usr/share/cdbs/' ],
 124         [ dbs => qr'^include\s+/usr/share/dbs/' ],
 125         [ 'dh-make-php' => qr'^include\s+/usr/share/cdbs/1/class/pear\.mk' ],
 126         [ debhelper => qr'^include\s+/usr/share/cdbs/1/rules/debhelper\.mk' ],
 127         [ dpatch => qr'^include\s+/usr/share/cdbs/1/rules/dpatch\.mk' ],
 128         [ quilt => qr'^include\s+/usr/share/cdbs/1/rules/patchsys-quilt\.mk' ],
 129         [ dpatch => qr'^include\s+/usr/share/dpatch/' ],
 130         [ quilt => qr'^include\s+/usr/share/quilt/' ],
 131         [ $PYTHON_DEPEND => qr'/usr/share/cdbs/1/class/python-distutils\.mk', 'missing-python-build-dependency' ],
 132 );
 133
 134 # These are similar, but the resulting dependency is only allowed, not
 135 # required.
 136 #
 137 # The xsfclean rule is specific to the packages maintained by the X Strike
 138 # Force, but there are enough of those to make the rule worthwhile.
 139 my @GLOBAL_CLEAN_ALLOWED = (
 140         [ patchutils => qr'^include\s+/usr/share/cdbs/1/rules/dpatch\.mk' ],
 141         [ patchutils => qr'^include\s+/usr/share/cdbs/1/rules/patchsys-quilt\.mk' ],
 142         [ patchutils => qr'^include\s+/usr/share/cdbs/1/rules/simple-patchsys\.mk' ],
 143         [ 'python-central' => qr'^DEB_PYTHON_SYSTEM\s*:?=\s*pycentral' ],
 144         [ 'python-support' => qr'^DEB_PYTHON_SYSTEM\s*:?=\s*pysupport' ],
 145         [ 'python-setuptools' => qr'/usr/share/cdbs/1/class/python-distutils\.mk' ],
 146         [ quilt => qr'^clean:\s+xsfclean\b' ],
 147 );
 148
 149 # A list of packages; regular expressions that, if they match anywhere in the
 150 # debian/rules file, this package must be listed in either Build-Depends or
 151 # Build-Depends-Indep as appropriate; and optional tags as above.
 152 my @GLOBAL_DEPENDS = (
 153         [ $PYTHON_DEPEND => qr'^\t\s*dh_python\s', 'missing-dh_python-build-dependency' ],
 154         [ 'python-central' => qr'^\t\s*dh_pycentral\s' ],
 155         [ 'python-support' => qr'^\t\s*dh_pysupport\s' ],
 156         [ 'python-central' => qr'^DEB_PYTHON_SYSTEM\s*:?=\s*pycentral' ],
 157         [ 'python-support' => qr'^DEB_PYTHON_SYSTEM\s*:?=\s*pysupport' ],
 158 );
 159
 160 # Similarly, this list of packages, regexes, and optional tags say that if the
 161 # regex matches in one of clean, build-arch, binary-arch, or a rule they
 162 # depend on, this package is allowed (and required) in Build-Depends.
 163 my @RULE_CLEAN_DEPENDS = (
 164         [ ant => qr'^\t\s*ant\s' ],
 165         [ debhelper => qr'^\t\s*dh_.+' ],
 166         [ dpatch => qr'^\t\s*dpatch\s' ],
 167         [ "po-debconf" => qr'^\t\s*debconf-updatepo\s' ],
 168         [ $PYTHON_DEPEND => qr'^\t\s*python\s', 'missing-python-build-dependency' ],
 169         [ $PYTHON_DEPEND => qr'\ssetup\.py\b', 'missing-python-build-dependency' ],
 170         [ quilt => qr'^\t\s*(\S+=\S+\s+)*quilt\s' ],
 171         [ yada => qr'^\t\s*yada\s' ],
 172 );
 173
 174 # Similar, but the resulting dependency is only allowed, not required.  We
 175 # permit a versioned dependency on perl-base because that used to be the
 176 # standard suggested dependency.  No package should be depending on just
 177 # perl-base, since it's Priority: required.
 178 my @RULE_CLEAN_ALLOWED = (
 179         [ patch => q'^\t\s*(?:perl debian/)?yada\s+unpatch' ],
 180         [ 'perl | perl-base (>= 5.6.0-16)' => qr'(^\t|\|\|)\s*(perl|\$\(PERL\))\s' ],
 181         [ 'perl-modules (>= 5.10) | libmodule-build-perl' => qr'(^\t|\|\|)\s*(perl|\$\(PERL\))\s+Build\b' ],
 182         [ 'python-setuptools' => qr'\ssetup\.py\b' ],
 183 );
 184
 185 # A simple list of regular expressions which, if they match anywhere in
 186 # debian/rules, indicate the requirements for debian/rules clean are complex
 187 # enough that we can't know what packages are permitted in Build-Depends and
 188 # should bypass the build-depends-without-arch-dep check completely.
 189 my @GLOBAL_CLEAN_BYPASS = (
 190         qr'^include\s*/usr/share/cdbs/1/class/ant\.mk',
 191         qr'^\s+dh\s+'
 192 );
 193
 194 # Mapping of package names to section names
 195 my @NAME_SECTION_MAPPINGS = (
 196     [ qr/-docs?$/      => 'doc'      ],
 197     [ qr/-dbg$/        => 'debug'    ],
 198     [ qr/^python-/     => 'python'   ],
 199     [ qr/^r-cran-/     => 'gnu-r'    ],
 200     [ qr/^lib.*-perl$/ => 'perl'     ],
 201     [ qr/^lib.*-cil$/  => 'cli-mono' ],
 202     [ qr/^lib.*-java$/ => 'java'     ],
 203     [ qr/^(?:lib)php-/ => 'php'      ],
 204     [ qr/^lib(?:hugs|ghc6)-/ => 'haskell'   ],
 205     [ qr/^lib.*-ruby(?:1\.\d)?$/ => 'ruby'  ],
 206     [ qr/^lib.*-ocaml-dev$/ => 'ocaml'      ],
 207     [ qr/^lib.*-dev$/  => 'libdevel' ],
 208 );
 209
 210 # Valid URI formats for the Vcs-* fields
 211 # currently only checks the protocol, not the actual format of the URI
 212 my %VCS_RECOMMENDED_URIS = (
 213     browser => qr;^https?://;,
 214     arch    => qr;^https?://;,
 215     bzr     => qr;^(lp:~|(?:nosmart\+)?https?://);,
 216     cvs     => qr;^:pserver:;,
 217     darcs   => qr;^https?://;,
 218     hg      => qr;^https?://;,
 219     git     => qr;^(?:git|https?|rsync)://;,
 220     svn     => qr;^(?:svn|(?:svn\+)?https?)://;,
 221     mtn     => qr;^[\w.-]+\s+\S+;, # that's a hostname followed by a module name
 222 );
 223 my %VCS_VALID_URIS = (
 224     arch    => qr;^https?://;,
 225     bzr     => qr;^(?:sftp|(?:bzr\+)?ssh)://;,
 226     cvs     => qr;^(?:-d\s*)?:(?:ext|pserver):;,
 227     git     => qr;^(?:git\+)?ssh://;,
 228     svn     => qr;^(?:svn\+)?ssh://;,
 229 );
 230
 231 our $PERL_CORE_PROVIDES = Maemian::Data->new('fields/perl-provides', '\s+');
 232 our $OBSOLETE_PACKAGES  = Maemian::Data->new('fields/obsolete-packages');
 233 our $VIRTUAL_PACKAGES   = Maemian::Data->new('fields/virtual-packages');
 234
 235 sub run {
 236
 237 my $pkg = shift;
 238 my $type = shift;
 239 my $info = shift;
 240 my $version;
 241 my $arch_indep;
 242
 243 unless (-d "fields") {
 244         fail("directory in lintian laboratory for $type package $pkg missing: fields");
 245 }
 246
 247 #---- Format
 248
 249 if ($type eq 'source') {
 250         my $format = $info->field('format');
 251         if (defined($format) and $format !~ /^\s*1\.0\s*\z/) {
 252                 tag 'unsupported-source-format', $format;
 253         }
 254 }
 255
 256 #---- Package
 257
 258 if ($type eq "binary"){
 259         if (not defined $info->field('package')) {
 260                 tag "no-package-name", "";
 261         } else {
 262                 my $name = $info->field('package');
 263
 264                 unfold("package", \$name);
 265                 tag "bad-package-name", "" unless $name =~ /^[A-Z0-9][-+\.A-Z0-9]+$/i;
 266                 tag "package-not-lowercase", "" if ($name =~ /[A-Z]/)
 267         }
 268 }
 269
 270 #---- Version
 271
 272 if (not defined $info->field('version')) {
 273         tag "no-version-field", "";
 274 } else {
 275         $version = $info->field('version');
 276
 277         unfold("version", \$version);
 278
 279         if (@_ = _valid_version($version)) {
 280                 my ($epoch, $upstream, $debian) = @_;
 281                 if ($upstream !~ /^\d/i) {
 282                         tag "upstream-version-not-numeric", "$version";
 283                 }
 284                 if (defined $debian) {
 285                         tag "debian-revision-should-not-be-zero", "$version"
 286                                 if $debian eq '-0';
 287                         my $ubuntu;
 288                         $debian =~ /^-([^.]+)(?:\.[^.]+)?(?:\.[^.]+)?(\..*)?$/;
 289                         my $extra = $2;
 290                         if (defined $extra) {
 291                                 $debian =~ /^-([^.]+ubuntu[^.]+)(?:\.\d+){1,3}(\..*)?$/;
 292                                 $ubuntu = 1;
 293                                 $extra = $2;
 294                         }
 295                         if (not defined $1 or defined $extra) {
 296                                 tag "debian-revision-not-well-formed", "$version";
 297                         }
 298                         if ($debian =~ /^-[^.-]+\.[^.-]+\./ and not $ubuntu) {
 299                                 tag "binary-nmu-uses-old-version-style", "$version"
 300                                         if $type eq 'binary';
 301                                 tag "binary-nmu-debian-revision-in-source", "$version"
 302                                         if $type eq 'source';
 303                         }
 304                 }
 305                 if ($version =~ /\+b\d+$/ && $type eq "source") {
 306                         tag "binary-nmu-debian-revision-in-source", "$version";
 307                 }
 308
 309                 # Checks for the dfsg convention for repackaged upstream
 310                 # source.  Only check these against the source package to not
 311                 # repeat ourselves too much.
 312                 if ($type eq 'source') {
 313                         if ($version =~ /dfsg/ and $info->native) {
 314                                 tag 'dfsg-version-in-native-package', $version;
 315                         } elsif ($version =~ /\.dfsg/) {
 316                                 tag 'dfsg-version-with-period', $version;
 317                         } elsif ($version =~ /dsfg/) {
 318                                 tag 'dfsg-version-misspelled', $version;
 319                         }
 320                 }
 321
 322                 my $name = $info->field('package');
 323                 if ($name && $PERL_CORE_PROVIDES->known($name) &&
 324                     perl_core_has_version($name, '>=', $upstream)) {
 325                         my $core_version = $PERL_CORE_PROVIDES->value($name);
 326                         tag "package-superseded-by-perl", "with $core_version"
 327                 }
 328         } else {
 329                 tag "bad-version-number", "$version";
 330         }
 331 }
 332
 333 #---- Architecture
 334
 335 if (not defined $info->field('architecture')) {
 336         tag "no-architecture-field", "";
 337 } else {
 338         my $archs = $info->field('architecture');
 339
 340         unfold("architecture", \$archs);
 341
 342         my @archs = split / /, $archs;
 343
 344         if (@archs > 1 && grep { $_ eq "any" || ($type ne "source" && $_ eq "all") } @archs) {
 345                 tag "magic-arch-in-arch-list", "";
 346         }
 347
 348         for my $arch (@archs) {
 349                 tag "unknown-architecture", "$arch" unless $KNOWN_ARCHS->known($arch);
 350         }
 351
 352         if ($type eq "binary") {
 353                 tag "too-many-architectures", "" if (@archs > 1);
 354                 tag "arch-any-in-binary-pkg", "" if (grep { $_ eq "any" } @archs);
 355                 tag "aspell-package-not-arch-all", ""
 356                     if ($pkg =~ /^aspell-[a-z]{2}(-.*)?$/ && (@archs > 1 || $archs[0] ne 'all'));
 357         }
 358
 359         # Used for later tests.
 360         $arch_indep = 1 if (@archs == 1 && $archs[0] eq 'all');
 361 }
 362
 363 #---- Subarchitecture (udeb)
 364
 365 if (defined $info->field('subarchitecture')) {
 366         my $subarch = $info->field('subarchitecture');
 367
 368         unfold("subarchitecture", \$subarch);
 369 }
 370
 371 #---- Maintainer
 372 #---- Uploaders
 373
 374 for my $f (qw(maintainer uploaders)) {
 375         if (not defined $info->field($f)) {
 376                 tag "no-maintainer-field", "" if $f eq "maintainer";
 377         } else {
 378                 my $maintainer = $info->field($f);
 379
 380                 # Note, not expected to hit on uploaders anymore, as dpkg now strips
 381                 # newlines for the .dsc, and the newlines don't hurt in debian/control
 382                 unfold($f, \$maintainer);
 383
 384                 if ($f eq "uploaders") {
 385                         my @uploaders = split /\s*,\s*/, $maintainer;
 386                         my %duplicate_uploaders;
 387                         for my $uploader (@uploaders) {
 388                                 check_maintainer($uploader, "uploader");
 389                                 if ( ((grep { $_ eq $uploader } @uploaders) > 1) and
 390                                      ($duplicate_uploaders{$uploader}++ == 0)) {
 391                                         tag 'duplicate-uploader', $uploader;
 392                                 }
 393                         }
 394                 } else {
 395                         check_maintainer($maintainer, $f);
 396                         if ($type eq 'source'
 397                             && $maintainer =~ /\@lists(\.alioth)?\.debian\.org\b/
 398                             && ! defined $info->field('uploaders')) {
 399                                 tag 'no-human-maintainers';
 400                         }
 401                 }
 402         }
 403 }
 404
 405 if (defined $info->field('uploaders') && defined $info->field('maintainer')) {
 406         my $maint = $info->field('maintainer');
 407         tag 'maintainer-also-in-uploaders'
 408                 if $info->field('uploaders') =~ m/\Q$maint/;
 409 }
 410
 411 #---- Source
 412
 413 if (not defined $info->field('source')) {
 414         tag "no-source-field" if $type eq "source";
 415 } else {
 416         my $source = $info->field('source');
 417
 418         unfold("source", \$source);
 419
 420         if ($type eq 'source') {
 421                 if ($source ne $pkg) {
 422                         tag "source-field-does-not-match-pkg-name", "$source != $pkg";
 423                 }
 424         } else {
 425                 if ($source !~ /[A-Z0-9][-+\.A-Z0-9]+                      #Package name
 426                                 \s*
 427                                 (?:\((?:\d+:)?(?:[-\.+:A-Z0-9~]+?)(?:-[\.+A-Z0-9~]+)?\))?\s*$/ix) { #Version
 428                         tag "source-field-malformed", "$source";
 429                 }
 430         }
 431 }
 432
 433 #---- Essential
 434
 435 if (defined $info->field('essential')) {
 436         my $essential = $info->field('essential');
 437
 438         unfold("essential", \$essential);
 439
 440         tag "essential-in-source-package", "" if ($type eq "source");
 441         tag "essential-no-not-needed", "" if ($essential eq "no");
 442         tag "unknown-essential-value", "" if ($essential ne "no" and $essential ne "yes");
 443         tag "new-essential-package", "" if ($essential eq "yes" and ! $known_essential{$pkg});
 444 }
 445
 446 #---- Section
 447
 448 if (not defined $info->field('section')) {
 449         tag 'no-section-field' if ($type eq 'binary');
 450 } else {
 451         my $section = $info->field('section');
 452
 453         unfold("section", \$section);
 454
 455         if ($type eq 'udeb') {
 456             unless ($section eq 'debian-installer') {
 457                 tag "wrong-section-for-udeb", "$section";
 458             }
 459         } else {
 460             my @parts = split /\//, $section, 2;
 461
 462             if (scalar @parts > 1) {
 463                 tag "unknown-section", "$section" unless $known_archive_parts{$parts[0]};
 464                 tag "unknown-section", "$section" unless $known_sections{$parts[1]};
 465             } elsif ($parts[0] eq 'unknown') {
 466                 tag "section-is-dh_make-template";
 467             } else {
 468                 tag "unknown-section", "$section" unless $known_sections{$parts[0]};
 469             }
 470
 471             # Check package name <-> section.
 472             foreach my $map (@NAME_SECTION_MAPPINGS) {
 473                 if ($pkg =~ $map->[0]) {
 474                     tag "wrong-section-according-to-package-name", "$pkg => $map->[1]"
 475                         unless $parts[-1] eq $map->[1];
 476                     last;
 477                 }
 478             }
 479         }
 480 }
 481
 482 #---- Priority
 483
 484 if (not defined $info->field('priority')) {
 485         tag "no-priority-field", "" if $type eq "binary";
 486 } else {
 487         my $priority = $info->field('priority');
 488
 489         unfold("priority", \$priority);
 490
 491         tag "unknown-priority", "$priority" if (! $known_prios{$priority});
 492
 493         if ($pkg =~ /-dbg$/) {
 494                 tag "debug-package-should-be-priority-extra", $pkg
 495                     unless $priority eq 'extra';
 496         }
 497 }
 498
 499 #---- Standards-Version
 500 # handled in checks/standards-version
 501
 502 #---- Description
 503 # handled in checks/description
 504
 505 #--- Homepage
 506
 507 if (defined $info->field('homepage')) {
 508         my $homepage = $info->field('homepage');
 509
 510         unfold("homepage", \$homepage);
 511
 512         if ($homepage =~ /^<(?:UR[LI]:)?.*>$/i) {
 513                 tag "superfluous-clutter-in-homepage", $homepage;
 514         }
 515
 516         require URI;
 517         my $uri = URI->new($homepage);
 518
 519         unless ($uri->scheme) { # not an absolute URI
 520                 tag "bad-homepage", $homepage;
 521         }
 522
 523         if ($homepage =~ m,/search\.cpan\.org/.*-[0-9._]+/*$,) {
 524                 tag 'homepage-for-cpan-package-contains-version', $homepage;
 525         }
 526 } elsif ($type eq "binary" and not $info->native) {
 527         tag "no-homepage-field";
 528 }
 529
 530 #---- Installer-Menu-Item (udeb)
 531
 532 if (defined $info->field('installer-menu-item')) {
 533         my $menu_item = $info->field('installer-menu-item');
 534
 535         unfold('installer-menu-item', \$menu_item);
 536
 537         $menu_item =~ /^\d+$/ or tag "bad-menu-item", "$menu_item";
 538 }
 539
 540
 541 #---- Package relations (binary package)
 542
 543 # Check whether the package looks like a meta-package, used for later
 544 # dependency checks.  We consider a package to possibly be a meta-package if
 545 # it is a binary package, arch: all, with no files outside of /usr/share/doc.
 546 my $metapackage = 0;
 547 if ($type eq 'binary' && $arch_indep) {
 548         $metapackage = 1;
 549         foreach my $file (keys %{$info->index}) {
 550                 $metapackage = 0 unless ($info->index->{$file}->{type} =~ /^d/
 551                     || $file =~ m%^usr/share/doc/%);
 552         }
 553 }
 554 if (($type eq "binary") || ($type eq 'udeb')) {
 555         my (%deps, %fields, %parsed);
 556         for my $field (qw(depends pre-depends recommends suggests conflicts provides enhances replaces breaks)) {
 557                 if (defined $info->field($field)) {
 558                         #Get data and clean it
 559                         my $data = $info->field($field);;
 560                         unfold($field, \$data);
 561                         $fields{$field} = $data;
 562
 563                         my (@seen_libstdcs, @seen_tcls, @seen_tclxs, @seen_tks, @seen_tkxs, @seen_libpngs);
 564
 565                         my $is_dep_field = sub { grep { $_ eq $_[0] } qw(depends pre-depends recommends suggests) };
 566
 567                         tag "alternates-not-allowed", "$field"
 568                             if ($data =~ /\|/ && ! &$is_dep_field($field));
 569
 570                         for my $dep (split /\s*,\s*/, $data) {
 571                                 my (@alternatives, @seen_obsolete_packages);
 572                                 push @alternatives, [_split_dep($_), $_] for (split /\s*\|\s*/, $dep);
 573
 574                                 if (&$is_dep_field($field)) {
 575                                         push @seen_libstdcs, $alternatives[0]->[0]
 576                                             if defined $known_libstdcs{$alternatives[0]->[0]};
 577                                         push @seen_tcls, $alternatives[0]->[0]
 578                                             if defined $known_tcls{$alternatives[0]->[0]};
 579                                         push @seen_tclxs, $alternatives[0]->[0]
 580                                             if defined $known_tclxs{$alternatives[0]->[0]};
 581                                         push @seen_tks, $alternatives[0]->[0]
 582                                             if defined $known_tks{$alternatives[0]->[0]};
 583                                         push @seen_tkxs, $alternatives[0]->[0]
 584                                             if defined $known_tkxs{$alternatives[0]->[0]};
 585                                         push @seen_libpngs, $alternatives[0]->[0]
 586                                             if defined $known_libpngs{$alternatives[0]->[0]};
 587                                 }
 588
 589                                 # Only for (Pre-)?Depends.
 590                                 tag "virtual-package-depends-without-real-package-depends", "$field: $alternatives[0]->[0]"
 591                                     if ($VIRTUAL_PACKAGES->known($alternatives[0]->[0])
 592                                         && ($field eq "depends" || $field eq "pre-depends"));
 593
 594                                 # Check defaults for transitions.  Here, we only care that the first alternative is current.
 595                                 tag "depends-on-old-emacs", "$field: $alternatives[0]->[0]"
 596                                     if (&$is_dep_field($field) && $known_obsolete_emacs{$alternatives[0]->[0]});
 597
 598                                 for my $part_d (@alternatives) {
 599                                         my ($d_pkg, $d_version, $d_arch, $rest, $part_d_orig) = @$part_d;
 600
 601                                         tag "versioned-provides", "$part_d_orig"
 602                                             if ($field eq "provides" && $d_version->[0]);
 603
 604                                         tag "breaks-without-version", "$part_d_orig"
 605                                             if ($field eq "breaks" && !$d_version->[0]);
 606
 607                                         tag "obsolete-relation-form", "$field: $part_d_orig"
 608                                             if ($d_version && grep { $d_version->[0] eq $_ } ("<", ">"));
 609
 610                                         tag "bad-version-in-relation", "$field: $part_d_orig"
 611                                             if ($d_version->[0] && ! defined((_valid_version($d_version->[1]))[1]));
 612
 613                                         tag "package-relation-with-self", "$field: $part_d_orig"
 614                                             if ($pkg eq $d_pkg) && ($field ne 'conflicts');
 615
 616                                         tag "bad-relation", "$field: $part_d_orig"
 617                                             if $rest;
 618
 619                                         push @seen_obsolete_packages, $part_d_orig
 620                                             if ($OBSOLETE_PACKAGES->known($d_pkg) && &$is_dep_field($field));
 621
 622                                         tag "depends-on-x-metapackage", "$field: $part_d_orig"
 623                                             if ($known_x_metapackages{$d_pkg} && ! $metapackage && &$is_dep_field($field));
 624
 625                                         tag "depends-on-essential-package-without-using-version", "$field: $part_d_orig"
 626                                             if ($known_essential{$d_pkg} && ! $d_version->[0] && &$is_dep_field($field));
 627
 628                                         tag "package-depends-on-an-x-font-package", "$field: $part_d_orig"
 629                                             if ($field =~ /^(pre-)?depends$/ && $d_pkg =~ /^xfont.*/ && $d_pkg ne 'xfonts-utils' && $d_pkg ne 'xfongs-encodings');
 630
 631                                         tag "needlessly-depends-on-awk", "$field"
 632                                             if ($d_pkg eq "awk" && ! $d_version->[0] && &$is_dep_field($field));
 633
 634                                         tag "depends-on-libdb1-compat", "$field"
 635                                             if ($d_pkg eq "libdb1-compat" && $pkg !~ /^libc(6|6.1|0.3)/ && $field =~ /^(pre-)depends$/);
 636
 637                                         tag "depends-on-python-minimal", "$field",
 638                                             if ($d_pkg =~ /^python[\d.]*-minimal$/ && &$is_dep_field($field)
 639                                                 && $pkg !~ /^python[\d.]*-minimal$/);
 640
 641                                         tag "doc-package-depends-on-main-package", "$field"
 642                                             if ("$d_pkg-doc" eq $pkg && $field =~ /^(pre-)depends$/);
 643
 644                                         tag "old-versioned-python-dependency", "$field: $part_d_orig"
 645                                             if ($d_pkg eq 'python' && $d_version->[0] eq '<<' && &$is_dep_field($field)
 646                                                 && $arch_indep && $pkg =~ /^python-/ && ! defined $info->field('python-version')
 647                                                 && ! $info->relation('depends')->implies('python-support'));
 648
 649                                         # only trigger this for the the preferred alternative
 650                                         tag "versioned-dependency-satisfied-by-perl", "$field: $part_d_orig"
 651                                                 if $alternatives[0][-1] eq $part_d_orig
 652                                                 && &$is_dep_field($field)
 653                                                 && perl_core_has_version($d_pkg, $d_version->[0], $d_version->[1]);
 654
 655                                         tag "depends-exclusively-on-makedev", "$field",
 656                                             if ($field eq 'depends' && $d_pkg eq 'makedev' && @alternatives == 1);
 657                                 }
 658
 659                                 for my $pkg (@seen_obsolete_packages) {
 660                                         if ($pkg eq $alternatives[0]->[0] or
 661                                             scalar @seen_obsolete_packages == scalar @alternatives) {
 662                                                 tag "depends-on-obsolete-package", "$field: $pkg";
 663                                         } else {
 664                                                 tag "ored-depends-on-obsolete-package", "$field: $pkg";
 665                                         }
 666                                 }
 667                         }
 668                         tag "package-depends-on-multiple-libstdc-versions", @seen_libstdcs
 669                             if (scalar @seen_libstdcs > 1);
 670                         tag "package-depends-on-multiple-tcl-versions", @seen_tcls
 671                             if (scalar @seen_tcls > 1);
 672                         tag "package-depends-on-multiple-tclx-versions", @seen_tclxs
 673                             if (scalar @seen_tclxs > 1);
 674                         tag "package-depends-on-multiple-tk-versions", @seen_tks
 675                             if (scalar @seen_tks > 1);
 676                         tag "package-depends-on-multiple-tkx-versions", @seen_tkxs
 677                             if (scalar @seen_tkxs > 1);
 678                         tag "package-depends-on-multiple-libpng-versions", @seen_libpngs
 679                             if (scalar @seen_libpngs > 1);
 680                 }
 681         }
 682
 683         # If Conflicts or Breaks is set, make sure it's not inconsistent with
 684         # the other dependency fields.
 685         for my $conflict (qw/conflicts breaks/) {
 686                 next unless $fields{$conflict};
 687                 for my $field (qw(depends pre-depends recommends suggests)) {
 688                         next unless $info->field($field);
 689                         my $relation = $info->relation($field);
 690                         for my $package (split /\s*,\s*/, $fields{$conflict}) {
 691                                 tag "conflicts-with-dependency", $field, $package
 692                                     if $relation->implies($package);
 693                         }
 694                 }
 695         }
 696 }
 697
 698 #---- Package relations (source package)
 699
 700 if ($type eq "source") {
 701
 702         my $binpkgs = $info->binaries;
 703
 704         #Get number of arch-indep packages:
 705         my $arch_indep_packages = 0;
 706         my $arch_dep_packages = 0;
 707         foreach my $binpkg (keys %$binpkgs) {
 708                 my $arch = $info->binary_field($binpkg, 'architecture');
 709                 if ($arch eq 'all') {
 710                         $arch_indep_packages++;
 711                 } else {
 712                         $arch_dep_packages++;
 713                 }
 714         }
 715
 716         # Search through rules and determine which dependencies are required.
 717         # The keys in %needed and %needed_clean are the dependencies; the
 718         # values are the tags to use or the empty string to use the default
 719         # tag.
 720         my (%needed, %needed_clean, %allowed_clean, $bypass_needed_clean);
 721         open (RULES, '<', "debfiles/rules")
 722             or fail("cannot read debfiles/rules: $!");
 723         my $target = "none";
 724         my @rules = qw(clean binary-arch build-arch);
 725         my $maybe_skipping;
 726         while (<RULES>) {
 727                 if (/^ifn?(eq|def)\s/) {
 728                         $maybe_skipping++;
 729                 } elsif (/^endif\s/) {
 730                         $maybe_skipping--;
 731                 }
 732                 for my $rule (@GLOBAL_CLEAN_DEPENDS) {
 733                         if ($_ =~ /$rule->[1]/) {
 734                                 if ($maybe_skipping) {
 735                                         $allowed_clean{$rule->[0]} = 1;
 736                                 } else {
 737                                         $needed_clean{$rule->[0]} = $rule->[2] || $needed_clean{$rule->[0]} || '';
 738                                 }
 739                         }
 740                 }
 741                 for my $rule (@GLOBAL_CLEAN_ALLOWED) {
 742                         if ($_ =~ /$rule->[1]/) {
 743                                 $allowed_clean{$rule->[0]} = 1;
 744                         }
 745                 }
 746                 for my $rule (@GLOBAL_CLEAN_BYPASS) {
 747                         if ($_ =~ /$rule/) {
 748                                 $bypass_needed_clean = 1;
 749                         }
 750                 }
 751                 for my $rule (@GLOBAL_DEPENDS) {
 752                         if ($_ =~ /$rule->[1]/ && !$maybe_skipping) {
 753                                 $needed{$rule->[0]} = $rule->[2] || $needed{$rule->[0]} || '';
 754                         }
 755                 }
 756                 if (/^(\S+?):+(.*)/) {
 757                         $target = $1;
 758                         if (grep ($_ eq $target, @rules)) {
 759                                 push (@rules, split (' ', $2));
 760                         }
 761                 }
 762                 if (grep ($_ eq $target, @rules)) {
 763                         for my $rule (@RULE_CLEAN_DEPENDS) {
 764                                 if ($_ =~ /$rule->[1]/) {
 765                                         if ($maybe_skipping) {
 766                                                 $allowed_clean{$rule->[0]} = 1;
 767                                         } else {
 768                                                 $needed_clean{$rule->[0]} = $rule->[2] || $needed_clean{$rule->[0]} || '';
 769                                         }
 770                                 }
 771                         }
 772                         for my $rule (@RULE_CLEAN_ALLOWED) {
 773                                 if ($_ =~ /$rule->[1]/) {
 774                                         $allowed_clean{$rule->[0]} = 1;
 775                                 }
 776                         }
 777                 }
 778         }
 779         close RULES;
 780
 781         tag "build-depends-indep-without-arch-indep", ""
 782                 if (defined $info->field('build-depends-indep') && $arch_indep_packages == 0);
 783
 784         my $is_dep_field = sub { grep { $_ eq $_[0] } qw(build-depends build-depends-indep) };
 785
 786         my %depend;
 787         for my $field (qw(build-depends build-depends-indep build-conflicts build-conflicts-indep)) {
 788                 if (defined $info->field($field)) {
 789                         #Get data and clean it
 790                         my $data = $info->field($field);;
 791                         unfold($field, \$data);
 792                         $depend{$field} = $data;
 793
 794                         for my $dep (split /\s*,\s*/, $data) {
 795                                 my (@alternatives, @seen_obsolete_packages);
 796                                 push @alternatives, [_split_dep($_), $_] for (split /\s*\|\s*/, $dep);
 797
 798                                 tag "virtual-package-depends-without-real-package-depends", "$field: $alternatives[0]->[0]"
 799                                     if ($VIRTUAL_PACKAGES->known($alternatives[0]->[0]) && &$is_dep_field($field));
 800
 801                                 for my $part_d (@alternatives) {
 802                                         my ($d_pkg, $d_version, $d_arch, $rest, $part_d_orig) = @$part_d;
 803
 804                                         for my $arch (@{$d_arch->[0]}) {
 805                                                 if (!$KNOWN_ARCHS->known($arch)) {
 806                                                         tag "invalid-arch-string-in-source-relation", "$arch [$field: $part_d_orig]"
 807                                                 }
 808                                         }
 809
 810                                         tag "build-depends-on-build-essential", $field
 811                                             if ($d_pkg eq "build-essential");
 812
 813                                         tag "depends-on-build-essential-package-without-using-version", "$d_pkg [$field: $part_d_orig]"
 814                                             if ($known_build_essential{$d_pkg} && ! $d_version->[1]);
 815
 816                                         tag "build-depends-on-essential-package-without-using-version", "$field: $part_d_orig"
 817                                             if ($d_pkg ne "coreutils" && $known_essential{$d_pkg} && ! $d_version->[0]);
 818                                         push @seen_obsolete_packages, $part_d_orig
 819                                             if ($OBSOLETE_PACKAGES->known($d_pkg) && &$is_dep_field($field));
 820
 821                                         tag "build-depends-on-x-metapackage", "$field: $part_d_orig"
 822                                             if ($known_x_metapackages{$d_pkg} && &$is_dep_field($field));
 823
 824                                         tag "build-depends-on-1-revision", "$field: $part_d_orig"
 825                                             if ($d_version->[0] eq '>=' && $d_version->[1] =~ /-1$/ && &$is_dep_field($field));
 826
 827                                         tag "bad-relation", "$field: $part_d_orig"
 828                                             if $rest;
 829
 830                                         # only trigger this for the the preferred alternative
 831                                         tag "versioned-dependency-satisfied-by-perl", "$field: $part_d_orig"
 832                                                 if $alternatives[0][-1] eq $part_d_orig
 833                                                 && &$is_dep_field($field)
 834                                                 && perl_core_has_version($d_pkg, $d_version->[0], $d_version->[1]);
 835                                 }
 836
 837                                 for my $pkg (@seen_obsolete_packages) {
 838                                         if ($pkg eq $alternatives[0]->[0] or
 839                                             scalar @seen_obsolete_packages == scalar @alternatives) {
 840                                                 tag "build-depends-on-obsolete-package", "$field: $pkg";
 841                                         } else {
 842                                                 tag "ored-build-depends-on-obsolete-package", "$field: $pkg";
 843                                         }
 844                                 }
 845                         }
 846                 }
 847         }
 848
 849         # Check for duplicates.
 850         my $build_all = $info->relation('build-depends-all');
 851         my @dups = $build_all->duplicates;
 852         for my $dup (@dups) {
 853                 tag "package-has-a-duplicate-build-relation", join (', ', @$dup);
 854         }
 855
 856         # Make sure build dependencies and conflicts are consistent.
 857         my %parsed;
 858         for ($depend{'build-conflicts'}, $depend{'build-conflicts-indep'}) {
 859                 next unless $_;
 860                 for my $conflict (split /\s*,\s*/, $_) {
 861                         if ($build_all->implies($conflict)) {
 862                                 tag "build-conflicts-with-build-dependency", $conflict;
 863                         }
 864                 }
 865         }
 866
 867         # Make sure that all the required build dependencies are there.  Don't
 868         # issue missing-build-dependency errors for debhelper, since there's
 869         # another test that does that and it would just be a duplicate.
 870         my $build_regular = $info->relation('build-depends');
 871         my $build_indep   = $info->relation('build-depends-indep');
 872         for my $package (keys %needed_clean) {
 873                 my $tag = $needed_clean{$package} || 'missing-build-dependency';
 874                 unless ($build_regular->implies($package)) {
 875                         if ($build_indep->implies($package)) {
 876                                 tag "clean-should-be-satisfied-by-build-depends", $package;
 877                         } else {
 878                                 if ($tag eq 'missing-build-dependency') {
 879                                         tag $tag, $package if $package ne 'debhelper';
 880                                 } else {
 881                                         tag $tag;
 882                                 }
 883                         }
 884                 }
 885         }
 886         my $noarch = $info->relation_noarch('build-depends-all');
 887         for my $package (keys %needed) {
 888                 my $tag = $needed{$package} || 'missing-build-dependency';
 889
 890                 # dh_python deactivates itself if the new Python build policy
 891                 # is enabled.
 892                 if ($tag eq 'missing-dh_python-build-dependency') {
 893                         next if -f 'debfiles/pycomat';
 894                         next if defined $info->field('python-version');
 895                 }
 896                 unless ($noarch->implies($package)) {
 897                         if ($tag eq 'missing-build-dependency') {
 898                                 tag $tag, $package;
 899                         } else {
 900                                 tag $tag;
 901                         }
 902                 }
 903         }
 904
 905         # This check is a bit tricky.  We want to allow in Build-Depends a
 906         # dependency with any version, since reporting this tag over version
 907         # mismatches would be confusing and quite likely wrong.  The approach
 908         # taken is to strip the version information off all dependencies
 909         # allowed in Build-Depends, strip the version information off of the
 910         # dependencies in Build-Depends, and then allow any dependency in
 911         # Build-Depends that's implied by the dependencies we require or allow
 912         # there.
 913         #
 914         # We also have to map | to , when building the list of allowed
 915         # packages so that the implications will work properly.
 916         #
 917         # This is confusing.  There should be a better way to do this.
 918         if (defined $info->field('build-depends') && $arch_dep_packages == 0 && !$bypass_needed_clean) {
 919                 my $build_depends = $info->field('build-depends');
 920                 my @packages = split /\s*,\s*/, $build_depends;
 921                 my @allowed = map { s/\([^\)]+\)//g; s/\|/,/g; $_ } keys (%needed_clean), keys (%allowed_clean);
 922                 my $dep = Maemian::Relation->new_noarch(join(',', @allowed));
 923                 foreach my $pkg (@packages) {
 924                         my $name = $pkg;
 925                         $name =~ s/[\[\(][^\)\]]+[\)\]]//g;
 926                         $name =~ s/\s+$//;
 927                         $name =~ s/\s+/ /g;
 928                         unless ($dep->implies($name)) {
 929                                 tag "build-depends-without-arch-dep", $name;
 930                         }
 931                 }
 932         }
 933
 934         my (@arch_dep_pkgs, @dbg_pkgs);
 935         foreach my $binpkg (keys %$binpkgs) {
 936                 if ($binpkg =~ m/-dbg$/) {
 937                         push @dbg_pkgs, $binpkg;
 938                 } elsif ($info->binary_field($binpkg, 'architecture') ne 'all') {
 939                         push @arch_dep_pkgs, $binpkg;
 940                 }
 941         }
 942         foreach (@dbg_pkgs) {
 943                 my $deps;
 944                 $deps  = $info->binary_field($_, 'pre-depends') . ', ';
 945                 $deps .= $info->binary_field($_, 'depends');
 946                 tag 'dbg-package-missing-depends', $_
 947                    unless (grep {my $quoted_name = qr<\Q$_>; $deps =~ m/(\s|,|^)$quoted_name(\s|,|$)/} @arch_dep_pkgs);
 948         }
 949 }
 950
 951 #----- Origin
 952
 953 if (defined $info->field('origin')) {
 954         my $origin = $info->field('origin');
 955
 956         unfold('origin', \$origin);
 957
 958         tag "redundant-origin-field", "" if lc($origin) eq 'debian';
 959 }
 960
 961 #----- Bugs
 962
 963 if (defined $info->field('bugs')) {
 964         my $bugs = $info->field('bugs');
 965
 966         unfold('bugs', \$bugs);
 967
 968         tag "redundant-bugs-field"
 969             if $bugs =~ m,^debbugs://bugs.debian.org/?$,i;
 970 }
 971
 972 #----- Python-Version
 973
 974 if (defined $info->field('python-version')) {
 975         my $pyversion = $info->field('python-version');
 976
 977         unfold('python-version', \$pyversion);
 978
 979         my @valid = ([ '\d+\.\d+', '\d+\.\d+' ],
 980                      [ '\d+\.\d+' ],
 981                      [ '\>=\s*\d+\.\d+', '\<\<\s*\d+\.\d+' ],
 982                      [ '\>=\s*\d+\.\d+' ],
 983                      [ 'current', '\>=\s*\d+\.\d+' ],
 984                      [ 'current' ],
 985                      [ 'all' ]);
 986
 987         my @pyversion = split(/\s*,\s*/, $pyversion);
 988         if (@pyversion > 2) {
 989                 if (grep { !/^\d+\.\d+$/ } @pyversion) {
 990                         tag "malformed-python-version", "$pyversion";
 991                 }
 992         } else {
 993                 my $okay = 0;
 994                 for my $rule (@valid) {
 995                         if ($pyversion[0] =~ /^$rule->[0]$/
 996                             && (($pyversion[1] && $rule->[1] && $pyversion[1] =~ /^$rule->[1]$/)
 997                                  || (! $pyversion[1] && ! $rule->[1]))) {
 998                                 $okay = 1;
 999                                 last;
1000                         }
1001                 }
1002                 tag "malformed-python-version", "$pyversion" unless $okay;
1003         }
1004 }
1005
1006 #----- Dm-Upload-Allowed
1007
1008 if (defined $info->field('dm-upload-allowed')) {
1009         my $dmupload = $info->field('dm-upload-allowed');
1010
1011         unfold('dm-upload-allowed', \$dmupload);
1012
1013         unless ($dmupload eq 'yes') {
1014                 tag "malformed-dm-upload-allowed", "$dmupload";
1015         }
1016 }
1017
1018 #----- Vcs-*
1019
1020 while (my ($vcs, $regex) = each %VCS_RECOMMENDED_URIS) {
1021     if (defined $info->field("vcs-$vcs")) {
1022         my $uri = $info->field("vcs-$vcs");
1023         if ($uri !~ $regex) {
1024             if ($VCS_VALID_URIS{$vcs} and $uri =~ $VCS_VALID_URIS{$vcs}) {
1025                 tag "vcs-field-uses-not-recommended-uri-format", "vcs-$vcs", $uri;
1026             } else {
1027                 tag "vcs-field-uses-unknown-uri-format", "vcs-$vcs", $uri;
1028             }
1029         }
1030     }
1031 }
1032
1033
1034 #----- Field checks (without checking the value)
1035
1036 for my $field (glob("fields/*")) {
1037         $field =~ s!^fields/!!;
1038
1039         next if ($field eq 'original-maintainer') and $version =~ /ubuntu/;
1040
1041         tag "obsolete-field", "$field"
1042             if $known_obsolete_fields{$field};
1043
1044         tag "unknown-field-in-dsc", "$field"
1045             if ($type eq "source" && ! $known_source_fields{$field} && ! $known_obsolete_fields{$field});
1046
1047         tag "unknown-field-in-control", "$field"
1048             if ($type eq "binary" && ! $known_binary_fields{$field} && ! $known_obsolete_fields{$field});
1049
1050         tag "unknown-field-in-control", "$field"
1051             if ($type eq "udeb" && ! $known_udeb_fields{$field} && ! $known_obsolete_fields{$field});
1052 }
1053
1054 }
1055
1056 # splits "foo (>= 1.2.3) [!i386 ia64]" into
1057 # ( "foo", [ ">=", "1.2.3" ], [ [ "i386", "ia64" ], 1 ], "" )
1058 #                                                  ^^^   ^^
1059 #                                 true, if ! was given   ||
1060 #           rest (should always be "" for valid dependencies)
1061 sub _split_dep {
1062         my $dep = shift;
1063         my ($pkg, $version, $darch) = ("", ["",""], [[],""]);
1064
1065         $pkg = $1 if $dep =~ s/^\s*([^\s\[\(]+)\s*//;
1066
1067         if (length $dep) {
1068                 if ($dep =~ s/\s* \( \s* (<<|<=|<|=|>=|>>|>) \s* ([^\s(]+) \s* \) \s*//x) {
1069                         @$version = ($1, $2);
1070                 }
1071                 if ($dep && $dep =~ s/\s*\[([^\]]+)\]\s*//) {
1072                         my $t = $1;
1073                         $darch->[1] = 1 if ($t =~ s/!//g);
1074                         $darch->[0] = [ split /\s+/, $t ];
1075                 }
1076         }
1077
1078         return ($pkg, $version, $darch, $dep);
1079 }
1080
1081 sub _valid_version {
1082         my $ver = shift;
1083
1084         # epoch check means nothing here... This check is only useful to detect
1085         # weird characters in version (and to get the debian revision)
1086         if ($ver =~ m/^(\d+:)?([-\.+:~A-Z0-9]+?)(-[\.+~A-Z0-9]+)?$/i) {
1087                 return ($1, $2, $3);
1088         } else {
1089                 return ();
1090         }
1091 }
1092
1093 sub perl_core_has_version {
1094         my ($package, $op, $version) = @_;
1095         my $core_version = $PERL_CORE_PROVIDES->value($package);
1096         return 0 if !defined $core_version;
1097         my @version = _valid_version($version);
1098         return 0 if !@version;
1099         return versions_compare($core_version, $op, $version);
1100 }
1101
1102 sub unfold {
1103         my $field = shift;
1104         my $line = shift;
1105
1106         $$line =~ s/\n$//;
1107
1108         if ($$line =~ s/\n//g) {
1109                 tag "multiline-field", "$field";
1110         }
1111 }
1112
1113 1;
1114
1115 # Local Variables:
1116 # indent-tabs-mode: t
1117 # cperl-indent-level: 8
1118 # End:
1119 # vim: syntax=perl sw=4 ts=4 noet shiftround