# fields -- lintian check script (rewrite) -*- perl -*-
#
# Copyright (C) 2004 Marc Brockschmidt
#
# Parts of the code were taken from the old check script, which
# was Copyright (C) 1998 Richard Braakman (also licensed under the
# GPL 2 or higher)
#
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 2 of the License, or
# (at your option) any later version.
#
# This program is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
# GNU General Public License for more details.
#
# You should have received a copy of the GNU General Public License
# along with this program.  If not, you can find it on the World Wide
# Web at http://www.gnu.org/copyleft/gpl.html, or write to the Free
# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
# MA 02110-1301, USA.

package Lintian::fields;
use strict;
use warnings;
use autodie;

use Dpkg::Version qw(version_check);
use List::MoreUtils qw(any true);

use Lintian::Architecture qw(:all);
use Lintian::Data ();
use Lintian::Check qw(check_maintainer);
use Lintian::Relation qw(:constants);
use Lintian::Relation::Version qw(versions_compare);
use Lintian::Tags qw(tag);
use Lintian::Util qw($PKGNAME_REGEX);

our $KNOWN_ESSENTIAL = Lintian::Data->new('fields/essential');
our $KNOWN_METAPACKAGES = Lintian::Data->new('fields/metapackages');
our $NO_BUILD_DEPENDS = Lintian::Data->new('fields/no-build-depends');
our $KNOWN_SECTIONS = Lintian::Data->new('fields/archive-sections');
our $known_build_essential
  = Lintian::Data->new('fields/build-essential-packages');
our $KNOWN_BINARY_FIELDS = Lintian::Data->new('fields/binary-fields');
our $KNOWN_UDEB_FIELDS = Lintian::Data->new('fields/udeb-fields');
our $KNOWN_BUILD_PROFILES = Lintian::Data->new('fields/build-profiles');

our %KNOWN_ARCHIVE_PARTS = map { $_ => 1 } ('non-free', 'contrib');

my $KNOWN_PRIOS = Lintian::Data->new('common/priorities', qr/\s*=\s*/o);

our @supported_source_formats = (qr/1\.0/, qr/3\.0\s*\((quilt|native)\)/);

# Still in the archive but shouldn't be the primary Emacs dependency.
our %known_obsolete_emacs = map { $_ => 1 } ('emacs21', 'emacs22');

our %known_libstdcs = map { $_ => 1 } (
    'libstdc++2.9-glibc2.1', 'libstdc++2.10',
    'libstdc++2.10-glibc2.2','libstdc++3',
    'libstdc++3.0', 'libstdc++4',
    'libstdc++5','libstdc++6',
    'lib64stdc++6',
);

our %known_tcls = map { $_ => 1 }
  ('tcl74', 'tcl8.0', 'tcl8.2', 'tcl8.3', 'tcl8.4', 'tcl8.5',);

our %known_tclxs
  = map { $_ => 1 } ('tclx76', 'tclx8.0.4', 'tclx8.2', 'tclx8.3', 'tclx8.4',);

our %known_tks
  = map { $_ => 1 } ('tk40', 'tk8.0', 'tk8.2', 'tk8.3', 'tk8.4', 'tk8.5',);

our %known_tkxs = map { $_ => 1 } ('tkx8.2', 'tkx8.3',);

our %known_libpngs = map { $_ => 1 } ('libpng12-0', 'libpng2', 'libpng3',);

our @known_java_pkg = map { qr/$_/ } (
    'default-jre(?:-headless)?', 'default-jdk', # default java
    'java\d*-runtime(?:-headless)?'
    , # java-runtime and javaX-runtime alternatives (virtual)
    '(openjdk-|sun-java)\d+-jre(?:-headless)?',
    '(openjdk-|sun-java)\d+-jdk', # openjdk-X and sun-javaX
    'gcj-(?:\d+\.\d+-)?jre(?:-headless)?', 'gcj-(?:\d+\.\d+-)?jdk', # gcj
    'gij',
    'java-gcj-compat(?:-dev|-headless)?', # deprecated/transitional packages
    'kaffe', 'cacao', 'jamvm',
    'classpath', # deprecated packages (removed in Squeeze)
);

# Mapping of package names to section names
my @NAME_SECTION_MAPPINGS = (
    [qr/-docs?$/                      => 'doc'],
    [qr/-dbg$/                        => 'debug'],
    [qr/^(?:python-)?zope/            => 'zope'],
    [qr/^python-/                     => 'python'],
    [qr/^r-cran-/                     => 'gnu-r'],
    [qr/^lib.*-perl$/                 => 'perl'],
    [qr/^lib.*-cil(?:-dev)?$/         => 'cli-mono'],
    [qr/^lib.*-(?:java|gcj)$/         => 'java'],
    [qr/^(?:lib)php-/                 => 'php'],
    [qr/^lib(?:hugs|ghc6?)-/          => 'haskell'],
    [qr/^lib.*-ruby(?:1\.\d)?$/       => 'ruby'],
    [qr/^lib.*-(?:ocaml|camlp4)-dev$/ => 'ocaml'],
    [qr/^lib.*-dev$/                  => 'libdevel'],
    [qr/^gir\d+\.\d+-.*-\d+\.\d+$/    => 'introspection'],
);

my %VCS_EXTRACT = (
    browser => sub { return @_;},
    arch    => sub { return @_;},
    bzr     => sub { return @_;},
    # cvs rootdir followed by optional module name:
    cvs     => sub { return shift =~ /^(.+?)(?:\s+(\S*))?$/;},
    darcs   => sub { return @_;},
    hg      => sub { return @_;},
    # git uri followed by optional " -b " + branchname:
    git     => sub { return shift =~ /^(.+?)(?:\s+-b\s+(\S*))?$/;},
    svn     => sub { return @_;},
    # that's a hostname followed by a module name:
    mtn     => sub { return shift =~ /^(.+?)\s+(\S+)$/;},
);
my %VCS_CANONIFY = (
    browser => sub {
        $_[0] =~ s{https?://svn\.debian\.org/wsvn/}
                  {http://anonscm.debian.org/viewvc/};
        $_[0] =~ s{\Qhttp://git.debian.org/?p=\E}
                  {https://anonscm.debian.org/cgit/};
        $_[0] =~ s{\Qhttp://bzr.debian.org/loggerhead/\E}
                  {http://anonscm.debian.org/loggerhead/};
        if ($_[0] =~ m{\Qhttp://anonscm.debian.org/viewvc/\E}xsm) {
            if ($_[0] =~ s{\?(.*[;\&])?op=log(?:[;\&](.*))?\Z}{}xsm) {
                my (@keep) = ($1, $2, $3);
                my $final = join('', grep {defined} @keep);
                $_[0] .= '?' . $final if ($final ne '');
                $_[1] = 'vcs-field-bitrotted';
            }
        }
    },
    cvs      => sub {
        if (
            $_[0] =~ s{\@(?:cvs.alioth|anonscm)\.debian\.org:/cvsroot/}
                      {\@anonscm.debian.org:/cvs/}
          ) {
            $_[1] = 'vcs-field-bitrotted';
        }
        $_[0] =~ s{\@cvs.alioth.debian.org:/cvs/}{\@anonscm.debian.org:/cvs/};
    },
    arch     => sub {
        $_[0] =~ s{\Qhttp://arch.debian.org/arch/\E}
                  {http://anonscm.debian.org/arch/};
    },
    bzr     => sub {
        $_[0] =~ s{\Qhttp://bzr.debian.org/\E}
                  {http://anonscm.debian.org/bzr/};
        $_[0] =~ s{\Qhttp://anonscm.debian.org/bzr/bzr/\E}
                  {http://anonscm.debian.org/bzr/};
    },
    git     => sub {
        if (
            $_[0] =~ s{git://(?:git|anonscm)\.debian\.org/~}
                      {git://anonscm.debian.org/users/}
          ) {
            $_[1] = 'vcs-git-uses-invalid-user-uri';
        }
        $_[0] =~ s{\Qhttp://git.debian.org/\E}
                  {http://anonscm.debian.org/git/};
        $_[0] =~ s{\Qhttp://anonscm.debian.org/git/git/\E}
                  {http://anonscm.debian.org/git/};
        $_[0] =~ s{\Qgit://git.debian.org/\E}
                  {git://anonscm.debian.org/};
        $_[0] =~ s{\Qgit://anonscm.debian.org/git/\E}
                  {git://anonscm.debian.org/};
    },
    hg      => sub {
        $_[0] =~ s{\Qhttp://hg.debian.org/\E}
                  {http://anonscm.debian.org/hg/};
        $_[0] =~ s{\Qhttp://anonscm.debian.org/hg/hg/\E}
                  {http://anonscm.debian.org/hg/};
    },
    svn     => sub {
        $_[0] =~ s{\Qsvn://cvs.alioth.debian.org/\E}
                  {svn://anonscm.debian.org/};
        $_[0] =~ s{\Qsvn://svn.debian.org/\E}
                  {svn://anonscm.debian.org/};
        $_[0] =~ s{\Qsvn://anonscm.debian.org/svn/\E}
                  {svn://anonscm.debian.org/};
    },
);
# Valid URI formats for the Vcs-* fields
# currently only checks the protocol, not the actual format of the URI
my %VCS_RECOMMENDED_URIS = (
    browser => qr;^https?://;,
    arch    => qr;^https?://;,
    bzr     => qr;^(?:lp:|(?:nosmart\+)?https?://);,
    cvs     => qr;^:(?:pserver:|ext:_?anoncvs);,
    darcs   => qr;^https?://;,
    hg      => qr;^https?://;,
    git     => qr;^(?:git|https?|rsync)://;,
    svn     => qr;^(?:svn|(?:svn\+)?https?)://;,
    mtn     => qr;^[\w.-]+$;,
);
my %VCS_VALID_URIS = (
    arch    => qr;^https?://;,
    bzr     => qr;^(?:sftp|(?:bzr\+)?ssh)://;,
    cvs     => qr;^(?:-d\s*)?:(?:ext|pserver):;,
    hg      => qr;^ssh://;,
    git     => qr;^(?:git\+)?ssh://;,
    svn     => qr;^(?:svn\+)?ssh://;,
);

# Python development packages that are used almost always just for building
# architecture-dependent modules.  Used to check for unnecessary build
# dependencies for architecture-independent source packages.
our $PYTHON_DEV = join(' | ',
    qw(python-dev python-all-dev python3-dev python3-all-dev),
    map { "python$_-dev" } qw(2.7 3 3.2));

our $PERL_CORE_PROVIDES = Lintian::Data->new('fields/perl-provides', '\s+');
our $OBSOLETE_PACKAGES
  = Lintian::Data->new('fields/obsolete-packages',qr/\s*=>\s*/);
our $VIRTUAL_PACKAGES   = Lintian::Data->new('fields/virtual-packages');
our $SOURCE_FIELDS      = Lintian::Data->new('common/source-fields');

sub run {
    my ($pkg, $type, $info, $proc, $group) = @_;
    my ($version, $arch_indep);

    #---- Format

    if ($type eq 'source') {
        my $format = $info->field('format');
        if (defined($format)) {
            my $supported = 0;
            foreach my $f (@supported_source_formats){
                if($format =~ /^\s*$f\s*\z/){
                    $supported = 1;
                }
            }
            tag 'unsupported-source-format', $format
              unless $supported;
        }
    }

    #---- Package

    if ($type eq 'binary') {
        if (not defined $info->field('package')) {
            tag 'no-package-name';
        } else {
            my $name = $info->field('package');

            unfold('package', \$name);
            tag 'bad-package-name' unless $name =~ /^$PKGNAME_REGEX$/i;
            tag 'package-not-lowercase' if ($name =~ /[A-Z]/);
        }
    }

    #---- Version

    if (not defined $info->field('version')) {
        tag 'no-version-field';
    } else {
        $version = $info->field('version');

        unfold('version', \$version);
        my $dversion = Dpkg::Version->new($version);

        if ($dversion->is_valid) {
            my ($epoch, $upstream, $debian)
              = ($dversion->epoch, $dversion->version, $dversion->revision);
            # Dpkg::Version sets the debian revision to 0 if there is
            # no revision.  So we need to check if the raw version
            # ends with "-0".
            tag 'debian-revision-should-not-be-zero', $version
              if $version =~ m/-0$/o;
            my $ubuntu;
            if($debian =~ m/^(?:[^.]+)(?:\.[^.]+)?(?:\.[^.]+)?(\..*)?$/o){
                my $extra = $1;
                if (
                    defined $extra
                    && $debian =~ m/\A
                            (?:[^.]+ubuntu[^.]+)(?:\.\d+){1,3}(\..*)?
                    \Z/oxsm
                  ) {
                    $ubuntu = 1;
                    $extra = $1;
                }
                if (defined $extra) {
                    tag 'debian-revision-not-well-formed', $version;
                }
            } else {
                tag 'debian-revision-not-well-formed', $version;
            }
            if ($debian =~ /^[^.-]+\.[^.-]+\./o and not $ubuntu) {
                tag 'binary-nmu-debian-revision-in-source', $version
                  if $type eq 'source';
            }
            if ($version =~ /\+b\d+$/ && $type eq 'source') {
                tag 'binary-nmu-debian-revision-in-source', $version;
            }
            if (
                $upstream =~ m/[^~a-z]
                    (rc|alpha|beta|dev|pre(?:view|release)?)
                   ([^a-z].*|\Z)
                 /xsm
              ) {
                my $expected = $upstream;
                my $rc = $1;
                my $rest = $2//'';
                my $suggestion;
                # Remove the rc-part and the preceeding symbol (if any).
                $expected =~ s/[\.\+\-\:]?\Q$rc\E.*//;
                $suggestion = "$expected~$rc$rest";
                tag 'rc-version-greater-than-expected-version', $upstream, '>',
                  $expected, "(consider using $suggestion)",
                  if $info->native
                  or ($debian eq q{1} or $debian =~ m,^0(?:\.1|ubuntu1)?$,);
            }

            # Checks for the dfsg convention for repackaged upstream
            # source.  Only check these against the source package to not
            # repeat ourselves too much.
            if ($type eq 'source') {
                if ($version =~ /dfsg/ and $info->native) {
                    tag 'dfsg-version-in-native-package', $version;
                } elsif ($version =~ /\.dfsg/) {
                    tag 'dfsg-version-with-period', $version;
                } elsif ($version =~ /dsfg/) {
                    tag 'dfsg-version-misspelled', $version;
                }
            }

            my $name = $info->field('package');
            if (   $name
                && $PERL_CORE_PROVIDES->known($name)
                && perl_core_has_version($name, '>=', "$epoch:$upstream")) {
                my $core_version = $PERL_CORE_PROVIDES->value($name);
                tag 'package-superseded-by-perl', "with $core_version";
            }
        } else {
            tag 'bad-version-number', $version;
        }
    }

    #---- Multi-Arch

    if (defined $info->field('multi-arch')){
        my $march = $info->field('multi-arch');
        unfold('multi-arch', \$march);
        tag 'unknown-multi-arch-value', $pkg, $march
          unless $march =~ m/^(?:no|foreign|allowed|same)$/o;
        if (   $march eq 'same'
            && $type eq 'binary'
            && defined $info->field('architecture')) {
            my $arch = $info->field('architecture');
            # Do not use unfold to avoid duplicate warning
            $arch =~ s/\n//o;
            tag 'illegal-multi-arch-value', $arch, $march if ($arch eq 'all');
        }
    }

    if ($type eq 'binary'){
        if ($pkg =~ /^fonts-/) {
            tag 'font-package-not-multi-arch-foreign'
              unless $info->field('multi-arch', 'no')
              =~ m/^(?:foreign|allowed)$/o;
        }
    }

    #---- Architecture

    if (not defined $info->field('architecture')) {
        tag 'no-architecture-field';
    } else {
        my $archs = $info->field('architecture');
        unfold('architecture', \$archs);

        my @archs = split(m/ /o, $archs);
        if (@archs > 1) { # Check for magic architecture combinations.
            my %archmap;
            my $magic = 0;
            $archmap{$_}++ for (@archs);
            $magic++ if ($type ne 'source' && $archmap{'all'});
            if ($archmap{'any'}){
                delete $archmap{'any'};
                # Allow 'all' to be present in source packages as well
                # (#626775)
                delete $archmap{'all'} if $type eq 'source';
                $magic++ if %archmap;
            }
            tag 'magic-arch-in-arch-list' if $magic;
        }
        for my $arch (@archs) {
            tag 'unknown-architecture', $arch
              unless is_arch_or_wildcard($arch);
            tag 'arch-wildcard-in-binary-package', $arch
              if ($type eq 'binary' && is_arch_wildcard($arch));
        }

        if ($type eq 'binary') {
            tag 'too-many-architectures' if (@archs > 1);
            if (@archs > 0) {
                tag 'aspell-package-not-arch-all'
                  if ( $pkg =~ /^aspell-[a-z]{2}(?:-.*)?$/
                    && $archs[0] ne 'all');
                if ($pkg =~ /-docs?$/ && $archs[0] ne 'all') {
                    tag 'documentation-package-not-architecture-independent';
                }
            }
        }
        # Used for later tests.
        $arch_indep = 1 if (@archs == 1 && $archs[0] eq 'all');
    }

    #---- Subarchitecture (udeb)

    if (defined $info->field('subarchitecture')) {
        my $subarch = $info->field('subarchitecture');

        unfold('subarchitecture', \$subarch);
    }

    #---- Maintainer
    #---- Uploaders

    for my $f (qw(maintainer uploaders)) {
        if (not defined $info->field($f)) {
            tag 'no-maintainer-field' if $f eq 'maintainer';
        } else {
            my $maintainer = $info->field($f);

            # Note, not expected to hit on uploaders anymore, as dpkg
            # now strips newlines for the .dsc, and the newlines don't
            # hurt in debian/control
            unfold($f, \$maintainer);

            if ($f eq 'uploaders') {
                my %duplicate_uploaders;
                my @uploaders = map { split /\@\S+\K\s*,\s*/ }
                  split />\K\s*,\s*/, $maintainer;
                for my $uploader (@uploaders) {
                    check_maintainer($uploader, 'uploader');
                    if (   ((true { $_ eq $uploader } @uploaders) > 1)
                        and($duplicate_uploaders{$uploader}++ == 0)) {
                        tag 'duplicate-uploader', $uploader;
                    }
                }
            } else {
                check_maintainer($maintainer, $f);
                if (   $type eq 'source'
                    && $maintainer =~ /\@lists(?:\.alioth)?\.debian\.org\b/
                    && !defined $info->field('uploaders')) {
                    tag 'no-human-maintainers';
                }
            }
        }
    }

    if (   defined $info->field('uploaders')
        && defined $info->field('maintainer')) {
        my $maint = $info->field('maintainer');
        tag 'maintainer-also-in-uploaders'
          if $info->field('uploaders') =~ m/\Q$maint/;
    }

    #---- Source

    if (not defined $info->field('source')) {
        # Optional in binary packages, required in source packages, but we
        # cannot check it as dpkg-source(1) refuses to unpack source packages
        # without this field (and fields indirectly depends on unpacked).  So
        # "pass"...
        1;
    } else {
        my $source = $info->field('source');

        unfold('source', \$source);

        if ($type eq 'source') {
            my $filename = $proc->pkg_path;
            my ($base) = ($filename =~ m,(?:\a|/)([^/]+)$,o);
            my ($n) = ($base =~ m/^([^_]+)_/o);

            if ($source ne $n) {
                tag 'source-field-does-not-match-pkg-name', "$source != $n";
            }
            if ($source !~ /^[a-z0-9][-+\.a-z0-9]+\z/) {
                tag 'source-field-malformed', $source;
            }
        } elsif (
            $source !~ /^ $PKGNAME_REGEX
            \s*
            # Optional Version e.g. (1.0)
            (?:\((?:\d+:)?(?:[-\.+:a-zA-Z0-9~]+?)(?:-[\.+a-zA-Z0-9~]+)?\))?\s*$/x
          ) {
            tag 'source-field-malformed', $source;
        }
    }

    #---- Essential

    if (defined $info->field('essential')) {
        my $essential = $info->field('essential');

        unfold('essential', \$essential);

        tag 'essential-in-source-package' if ($type eq 'source');
        tag 'essential-no-not-needed' if ($essential eq 'no');
        tag 'unknown-essential-value'
          if ($essential ne 'no' and $essential ne 'yes');
        if ($essential eq 'yes' and not $KNOWN_ESSENTIAL->known($pkg)) {
            tag 'new-essential-package';
        }
    }

    #---- Section

    if (not defined $info->field('section')) {
        tag 'no-section-field' if ($type eq 'binary');
    } else {
        my $section = $info->field('section');

        unfold('section', \$section);

        if ($type eq 'udeb') {
            unless ($section eq 'debian-installer') {
                tag 'wrong-section-for-udeb', $section;
            }
        } else {
            my @parts = split(m{/}, $section, 2);

            if (scalar @parts > 1) {
                tag 'unknown-section', $section
                  unless $KNOWN_ARCHIVE_PARTS{$parts[0]};
                tag 'unknown-section', $section
                  unless $KNOWN_SECTIONS->known($parts[1]);
            } elsif ($parts[0] eq 'unknown') {
                tag 'section-is-dh_make-template';
            } else {
                tag 'unknown-section', $section
                  unless $KNOWN_SECTIONS->known($parts[0]);
            }

            # Check package name <-> section.  oldlibs is a special case; let
            # anything go there.
            if ($parts[-1] ne 'oldlibs') {
                foreach my $map (@NAME_SECTION_MAPPINGS) {
                    next unless ($pkg =~ $map->[0]);

                    my $area = '';
                    $area = "$parts[0]/" if (scalar @parts == 2);
                    tag 'wrong-section-according-to-package-name',
                      "$pkg => ${area}$map->[1]"
                      unless $parts[-1] eq $map->[1];
                    last;
                }
            }
            if ($info->is_pkg_class('transitional')) {
                my $pri = $info->field('priority', '');
                # Cannot use "unfold" as it could emit a tag for priority,
                # which will be duplicated below.
                $pri =~ s/\n//;
                tag 'transitional-package-should-be-oldlibs-extra',
                  "$parts[-1]/$pri"
                  unless $pri eq 'extra' && $parts[-1] eq 'oldlibs';
            }
        }
    }

    #---- Priority

    if (not defined $info->field('priority')) {
        tag 'no-priority-field' if $type eq 'binary';
    } else {
        my $priority = $info->field('priority');

        unfold('priority', \$priority);

        tag 'unknown-priority', $priority
          unless $KNOWN_PRIOS->known($priority);

        if ($pkg =~ /-dbg$/) {
            tag 'debug-package-should-be-priority-extra', $pkg
              unless $priority eq 'extra';
        }
    }

    #---- Standards-Version
    # handled in checks/standards-version

    #---- Description
    # handled in checks/description

    #--- Homepage

    if (defined $info->field('homepage')) {
        my $homepage = $info->field('homepage');
        my $orig = $homepage;

        unfold('homepage', \$homepage);

        if ($homepage =~ /^<(?:UR[LI]:)?.*>$/i) {
            tag 'superfluous-clutter-in-homepage', $orig;
            $homepage = substr($homepage, 1, length($homepage) - 2);
        }

        require URI;
        my $uri = URI->new($homepage);

        # not an absolute URI or (most likely) an invalid protocol
        unless ($uri->scheme && $uri->scheme =~ m/^(?:ftp|https?|gopher)$/o) {
            tag 'bad-homepage', $orig;
        }

        if ($homepage=~ m,/(?:search\.cpan\.org|metacpan\.org)/.*-[0-9._]+/*$,)
        {
            tag 'homepage-for-cpan-package-contains-version', $orig;
        }
    } elsif (not $info->native) {
        if ($type eq 'source') {
            my $binary_has_homepage_field = 0;
            for my $binary ($info->binaries) {
                if (defined $info->binary_field($binary, 'homepage')) {
                    $binary_has_homepage_field = 1;
                    last;
                }
            }
            if ($binary_has_homepage_field) {
                tag 'homepage-in-binary-package';
            }
        } elsif ($type eq 'binary') {
            tag 'no-homepage-field';
        }
    }

    #---- Installer-Menu-Item (udeb)

    if (defined $info->field('installer-menu-item')) {
        my $menu_item = $info->field('installer-menu-item');

        unfold('installer-menu-item', \$menu_item);

        $menu_item =~ /^\d+$/ or tag 'bad-menu-item', $menu_item;
    }

    #---- Package relations (binary package)

    # Check whether the package looks like a metapackage, used for later
    # dependency checks.  We consider a package to possibly be a metapackage if
    # it is a binary package with no files outside of /usr/share/doc and a few
    # other directories found in metapackges.  This also catches documentation
    # packages, but that doesn't matter for our purposes.
    my $metapackage = 0;
    if ($type eq 'binary') {
        $metapackage = 1;
        for my $file ($info->sorted_index) {
            next if $file->is_dir;
            next if $file =~ m%^usr/share/doc/%;
            next if $file =~ m%^usr/share/lintian/overrides/%;
            next if $file =~ m%^usr/share/cdd/%;
            $metapackage = 0;
            last;
        }

        # Packages we say are metapackages are always metapackages even if
        # they don't look like it.
        $metapackage = 1 if $KNOWN_METAPACKAGES->known($pkg);
    }
    if (($type eq 'binary') || ($type eq 'udeb')) {
        my $javalib = 0;
        my $replaces = $info->relation('replaces');
        my %nag_once;
        $javalib = 1 if($pkg =~ m/^lib.*-java$/o);
        for my $field (
            qw(depends pre-depends recommends suggests conflicts provides enhances replaces breaks)
          ) {
            next unless defined $info->field($field);
            #Get data and clean it
            my $data = $info->field($field);
            my $javadep = 0;
            unfold($field, \$data);

            my (@seen_libstdcs, @seen_tcls, @seen_tclxs, @seen_tks, @seen_tkxs,
                @seen_libpngs);

            my $is_dep_field = sub {
                any { $_ eq $_[0] }qw(depends pre-depends recommends suggests);
            };

            tag 'alternates-not-allowed', $field
              if ($data =~ /\|/ && !&$is_dep_field($field));

            for my $dep (split /\s*,\s*/, $data) {
                my (@alternatives, @seen_obsolete_packages);
                push @alternatives, [_split_dep($_), $_]
                  for (split /\s*\|\s*/, $dep);

                if (&$is_dep_field($field)) {
                    push @seen_libstdcs, $alternatives[0]->[0]
                      if defined $known_libstdcs{$alternatives[0]->[0]};
                    push @seen_tcls, $alternatives[0]->[0]
                      if defined $known_tcls{$alternatives[0]->[0]};
                    push @seen_tclxs, $alternatives[0]->[0]
                      if defined $known_tclxs{$alternatives[0]->[0]};
                    push @seen_tks, $alternatives[0]->[0]
                      if defined $known_tks{$alternatives[0]->[0]};
                    push @seen_tkxs, $alternatives[0]->[0]
                      if defined $known_tkxs{$alternatives[0]->[0]};
                    push @seen_libpngs, $alternatives[0]->[0]
                      if defined $known_libpngs{$alternatives[0]->[0]};
                }

                # Only for (Pre-)?Depends.
                tag 'virtual-package-depends-without-real-package-depends',
                  "$field: $alternatives[0]->[0]"
                  if (
                       $VIRTUAL_PACKAGES->known($alternatives[0]->[0])
                    && ($field eq 'depends' || $field eq 'pre-depends')
                    && ($pkg ne 'base-files' || $alternatives[0]->[0] ne 'awk')
                    # ignore phpapi- dependencies as adding an
                    # alternative, real, package breaks its pourpose
                    && $alternatives[0]->[0] !~ m/^phpapi-/
                  );

                # Check defaults for transitions.  Here, we only care
                # that the first alternative is current.
                tag 'depends-on-old-emacs', "$field: $alternatives[0]->[0]"
                  if ( &$is_dep_field($field)
                    && $known_obsolete_emacs{$alternatives[0]->[0]});

                for my $part_d (@alternatives) {
                    my ($d_pkg, $d_march, $d_version, $d_arch, undef, $rest,
                        $part_d_orig)
                      = @$part_d;

                    tag 'versioned-provides', $part_d_orig
                      if ($field eq 'provides' && $d_version->[0]);

                    tag 'bad-provided-package-name', $d_pkg
                      if $d_pkg !~ /^[a-z0-9][-+\.a-z0-9]+$/;

                    tag 'breaks-without-version', $part_d_orig
                      if ( $field eq 'breaks'
                        && !$d_version->[0]
                        && !$VIRTUAL_PACKAGES->known($d_pkg)
                        && !$replaces->implies($part_d_orig));

                    tag 'conflicts-with-version', $part_d_orig
                      if ($field eq 'conflicts' && $d_version->[0]);

                    tag 'obsolete-relation-form', "$field: $part_d_orig"
                      if ($d_version && any { $d_version->[0] eq $_ }
                        ('<', '>'));

                    tag 'bad-version-in-relation', "$field: $part_d_orig"
                      if ($d_version->[0] && !version_check($d_version->[1]));

                    tag 'package-relation-with-self', "$field: $part_d_orig"
                      if ($pkg eq $d_pkg)
                      && ( $field ne 'conflicts'
                        && $field ne 'replaces'
                        && $field ne 'provides');

                    tag 'bad-relation', "$field: $part_d_orig"
                      if $rest;

                    push @seen_obsolete_packages, [$part_d_orig, $d_pkg]
                      if ( $OBSOLETE_PACKAGES->known($d_pkg)
                        && &$is_dep_field($field));

                    tag 'depends-on-metapackage', "$field: $part_d_orig"
                      if (  $KNOWN_METAPACKAGES->known($d_pkg)
                        and not $metapackage
                        and &$is_dep_field($field));

                    # diffutils is a special case since diff was
                    # renamed to diffutils, so a dependency on
                    # diffutils effectively is a versioned one.
                    tag 'depends-on-essential-package-without-using-version',
                      "$field: $part_d_orig"
                      if ( $KNOWN_ESSENTIAL->known($d_pkg)
                        && !$d_version->[0]
                        && &$is_dep_field($field)
                        && $d_pkg ne 'diffutils'
                        && $d_pkg ne 'dash');

                    tag 'package-depends-on-an-x-font-package',
                      "$field: $part_d_orig"
                      if ( $field =~ /^(pre-)?depends$/
                        && $d_pkg =~ /^xfont.*/
                        && $d_pkg ne 'xfonts-utils'
                        && $d_pkg ne 'xfonts-encodings');

                    tag 'depends-on-packaging-dev',
                      $field
                      if ((
                               $field =~ /^(?:pre-)?depends$/
                            || $field eq 'recommends'
                        )
                        && $d_pkg eq 'packaging-dev'
                        && !$info->is_pkg_class('any-meta'));

                    tag 'needless-suggest-recommend-libservlet-java', "$d_pkg"
                      if (($field eq 'recommends' || $field eq 'suggests')
                        && $d_pkg =~ m/libservlet[\d\.]+-java/);

                    tag 'needlessly-depends-on-awk', $field
                      if ( $d_pkg eq 'awk'
                        && !$d_version->[0]
                        && &$is_dep_field($field)
                        && $pkg ne 'base-files');

                    tag 'depends-on-libdb1-compat', $field
                      if ( $d_pkg eq 'libdb1-compat'
                        && $pkg !~ /^libc(?:6|6.1|0.3)/
                        && $field =~ m/^(?:pre-)?depends$/o);

                    tag 'depends-on-python-minimal', $field,
                      if ( $d_pkg =~ /^python[\d.]*-minimal$/
                        && &$is_dep_field($field)
                        && $pkg !~ /^python[\d.]*-minimal$/);

                    tag 'doc-package-depends-on-main-package', $field
                      if ("$d_pkg-doc" eq $pkg
                        && $field =~ /^(?:pre-)?depends$/);

                    # only trigger this for the the preferred alternative
                    tag 'versioned-dependency-satisfied-by-perl',
                      "$field: $part_d_orig"
                      if $alternatives[0][-1] eq $part_d_orig
                      && &$is_dep_field($field)
                      && perl_core_has_version($d_pkg, $d_version->[0],
                        $d_version->[1]);

                    tag 'depends-exclusively-on-makedev', $field,
                      if ( $field eq 'depends'
                        && $d_pkg eq 'makedev'
                        && @alternatives == 1);

                    tag 'lib-recommends-documentation', "$field: $part_d_orig"
                      if ( $field eq 'recommends'
                        && $pkg =~ m/^lib/
                        && $pkg !~ m/-(?:dev|docs?|tools|bin)$/
                        && $part_d_orig =~ m/-docs?$/);

                    # default-jdk-doc must depend on openjdk-X-doc (or
                    # classpath-doc) to be useful; other packages
                    # should depend on default-jdk-doc if they want
                    # the Java Core API.
                    tag 'depends-on-specific-java-doc-package',
                      $field
                      if (
                           &$is_dep_field($field)
                        && $pkg ne 'default-jdk-doc'
                        && (   $d_pkg eq 'classpath-doc'
                            || $d_pkg =~ m/openjdk-\d+-doc/o));

                    if ($javalib && $field eq 'depends'){
                        foreach my $reg (@known_java_pkg){
                            if($d_pkg =~ m/$reg/){
                                $javadep++;
                                last;
                            }

                        }
                    }
                }

                for my $d (@seen_obsolete_packages) {
                    my ($dep, $pkg_name) = @{$d};
                    my $replacement = $OBSOLETE_PACKAGES->value($pkg_name)
                      // '';
                    $replacement = ' => ' . $replacement
                      if $replacement ne '';
                    if ($pkg_name eq $alternatives[0]->[0]
                        or scalar @seen_obsolete_packages
                        == scalar @alternatives) {
                        tag 'depends-on-obsolete-package',
                          "$field: $dep${replacement}";
                    } else {
                        tag 'ored-depends-on-obsolete-package',
                          "$field: $dep${replacement}";
                    }
                }

                # Only emit the tag if all the alternatives are
                # JVM/JRE/JDKs
                # - assume that <some-lib> | openjdk-X-jre-headless
                #   makes sense for now.
                if (scalar(@alternatives) == $javadep
                    && !exists $nag_once{'needless-dependency-on-jre'}){
                    $nag_once{'needless-dependency-on-jre'} = 1;
                    tag 'needless-dependency-on-jre';
                }
            }
            tag 'package-depends-on-multiple-libstdc-versions', @seen_libstdcs
              if (scalar @seen_libstdcs > 1);
            tag 'package-depends-on-multiple-tcl-versions', @seen_tcls
              if (scalar @seen_tcls > 1);
            tag 'package-depends-on-multiple-tclx-versions', @seen_tclxs
              if (scalar @seen_tclxs > 1);
            tag 'package-depends-on-multiple-tk-versions', @seen_tks
              if (scalar @seen_tks > 1);
            tag 'package-depends-on-multiple-tkx-versions', @seen_tkxs
              if (scalar @seen_tkxs > 1);
            tag 'package-depends-on-multiple-libpng-versions', @seen_libpngs
              if (scalar @seen_libpngs > 1);
        }

        # If Conflicts or Breaks is set, make sure it's not inconsistent with
        # the other dependency fields.
        for my $conflict (qw/conflicts breaks/) {
            next unless $info->field($conflict);
            for my $field (qw(depends pre-depends recommends suggests)) {
                next unless $info->field($field);
                my $relation = $info->relation($field);
                for my $package (split /\s*,\s*/, $info->field($conflict)) {
                    tag 'conflicts-with-dependency', $field, $package
                      if $relation->implies($package);
                }
            }
        }
    }

    #---- Package relations (source package)

    if ($type eq 'source') {
        my @binpkgs = $info->binaries;

        #Get number of arch-indep packages:
        my $arch_indep_packages = 0;
        my $arch_dep_packages = 0;
        foreach my $binpkg (@binpkgs) {
            my $arch = $info->binary_field($binpkg, 'architecture', '');
            if ($arch eq 'all') {
                $arch_indep_packages++;
            } else {
                $arch_dep_packages++;
            }
        }

        tag 'build-depends-indep-without-arch-indep'
          if (defined $info->field('build-depends-indep')
            && $arch_indep_packages == 0);

        my $is_dep_field = sub {
            any { $_ eq $_[0] } qw(build-depends build-depends-indep);
        };

        my $restrictions_used = 0;
        my %depend;
        for my $field (
            qw(build-depends build-depends-indep build-conflicts build-conflicts-indep)
          ) {
            if (defined $info->field($field)) {
                #Get data and clean it
                my $data = $info->field($field);
                unfold($field, \$data);
                $depend{$field} = $data;

                for my $dep (split /\s*,\s*/, $data) {
                    my (@alternatives, @seen_obsolete_packages);
                    push @alternatives, [_split_dep($_), $_]
                      for (split /\s*\|\s*/, $dep);

                    tag 'virtual-package-depends-without-real-package-depends',
                      "$field: $alternatives[0]->[0]"
                      if ( $VIRTUAL_PACKAGES->known($alternatives[0]->[0])
                        && &$is_dep_field($field));

                    for my $part_d (@alternatives) {
                        my ($d_pkg, $d_march, $d_version, $d_arch, $d_restr,
                            $rest,$part_d_orig)
                          = @$part_d;

                        my $negated = 0;
                        for my $arch (@{$d_arch->[0]}) {
                            if ($arch eq 'all' || !is_arch_or_wildcard($arch)){
                                tag 'invalid-arch-string-in-source-relation',
                                  "$arch [$field: $part_d_orig]";
                            }
                        }

                        if (scalar @{$d_restr} >= 1) {
                            $restrictions_used = 1;
                        }

                        for my $restrlist (@{$d_restr}) {
                            for my $prof (@{$restrlist}) {
                                $prof =~ s/^!//;
                                tag 'invalid-profile-name-in-source-relation',
                                  "$prof [$field: $part_d_orig]"
                                  unless $KNOWN_BUILD_PROFILES->known($prof);
                            }
                        }

                        if (   $d_pkg =~ m/^openjdk-\d+-doc$/o
                            or $d_pkg eq 'classpath-doc'){
                            tag 'build-depends-on-specific-java-doc-package',
                              $d_pkg;
                        }

                        if ($d_pkg =~ m/^java-compiler$/o){
                            tag 'build-depends-on-an-obsolete-java-package',
                              $d_pkg;
                        }

                        if (    $d_pkg =~ m/^libdb\d+\.\d+.*-dev$/o
                            and &$is_dep_field($field)) {
                            tag 'build-depends-on-versioned-berkeley-db',
                              "$field:$d_pkg";
                        }

                        tag 'conflicting-negation-in-source-relation',
                          "$field: $part_d_orig"
                          unless (not $d_arch
                            or $d_arch->[1] == 0
                            or $d_arch->[1] eq @{ $d_arch->[0] });

                        tag 'depends-on-packaging-dev', $field
                          if ($d_pkg eq 'packaging-dev');

                        tag 'build-depends-on-build-essential', $field
                          if ($d_pkg eq 'build-essential');

                        #<<< no tidy, tag name too long
                        tag 'depends-on-build-essential-package-without-using-version',
                        #>>>
                          "$d_pkg [$field: $part_d_orig]"
                          if ($known_build_essential->known($d_pkg)
                            && !$d_version->[1]);

                        #<<< no tidy, tag name too long
                        tag 'build-depends-on-essential-package-without-using-version',
                        #>>>
                          "$field: $part_d_orig"
                          if ( $KNOWN_ESSENTIAL->known($d_pkg)
                            && !$d_version->[0]
                            && $d_pkg ne 'dash');
                        push @seen_obsolete_packages, [$part_d_orig, $d_pkg]
                          if ( $OBSOLETE_PACKAGES->known($d_pkg)
                            && &$is_dep_field($field));

                        tag 'build-depends-on-metapackage',
                          "$field: $part_d_orig"
                          if (  $KNOWN_METAPACKAGES->known($d_pkg)
                            and &$is_dep_field($field));

                        tag 'build-depends-on-non-build-package',
                          "$field: $part_d_orig"
                          if (  $NO_BUILD_DEPENDS->known($d_pkg)
                            and &$is_dep_field($field));

                        tag 'build-depends-on-1-revision',
                          "$field: $part_d_orig"
                          if ( $d_version->[0] eq '>='
                            && $d_version->[1] =~ /-1$/
                            && &$is_dep_field($field));

                        tag 'bad-relation', "$field: $part_d_orig"
                          if $rest;

                        # only trigger this for the the preferred alternative
                        tag 'versioned-dependency-satisfied-by-perl',
                          "$field: $part_d_orig"
                          if $alternatives[0][-1] eq $part_d_orig
                          && &$is_dep_field($field)
                          && perl_core_has_version($d_pkg, $d_version->[0],
                            $d_version->[1]);
                    }

                    my $all_obsolete = 0;
                    $all_obsolete = 1
                      if scalar @seen_obsolete_packages == @alternatives;
                    for my $d (@seen_obsolete_packages) {
                        my ($dep, $pkg_name) = @{$d};
                        my $replacement = $OBSOLETE_PACKAGES->value($pkg_name)
                          // '';
                        $replacement = ' => ' . $replacement
                          if $replacement ne '';
                        if (   $pkg_name eq $alternatives[0]->[0]
                            or $all_obsolete) {
                            tag 'build-depends-on-obsolete-package',
                              "$field: $dep${replacement}";
                        } else {
                            tag 'ored-build-depends-on-obsolete-package',
                              "$field: $dep${replacement}";
                        }
                    }
                }
            }
        }

        # Check for duplicates.
        my $build_all = $info->relation('build-depends-all');
        my @dups = $build_all->duplicates;
        for my $dup (@dups) {
            tag 'package-has-a-duplicate-build-relation', join(', ', @$dup);
        }

        # Make sure build dependencies and conflicts are consistent.
        for ($depend{'build-conflicts'}, $depend{'build-conflicts-indep'}) {
            next unless $_;
            for my $conflict (split /\s*,\s*/, $_) {
                if ($build_all->implies($conflict)) {
                    tag 'build-conflicts-with-build-dependency', $conflict;
                }
            }
        }

        # if restrictions are found in the build-depends/conflicts, then
        # package must build-depend on dpkg (>= 1.17.14)
        if ($restrictions_used) {
            my $build_conflicts_all = $info->relation('build-conflicts-all');
            tag 'restriction-formula-without-versioned-dpkg-dev-dependency'
              unless ($build_all->implies('dpkg-dev (>= 1.17.14)'));
            tag 'restriction-formula-with-versioned-dpkg-dev-conflict'
              if (
                $build_conflicts_all->implies_inverse('dpkg-dev (<< 1.17.14)')
              );
            # if the package uses debhelper then it must require and not
            # conflict with version >= 9.20141010
            if ($build_all->implies('debhelper')) {
                tag
'restriction-formula-with-debhelper-without-debhelper-version'
                  unless ($build_all->implies('debhelper (>= 9.20141010)'));
                #<<< no tidy, tag name too long
                tag 'restriction-formula-with-debhelper-with-conflicting-version'
                #>>>
                  if (
                    $build_conflicts_all->implies_inverse(
                        'debhelper (<< 9.20141010)'));
            }
        }

        my (@arch_dep_pkgs, @dbg_pkgs);
        foreach my $gproc ($group->get_binary_processables) {
            my $binpkg = $gproc->pkg_name;
            if ($binpkg =~ m/-dbg$/) {
                push(@dbg_pkgs, $gproc);
            } elsif ($info->binary_field($binpkg, 'architecture', '') ne 'all')
            {
                push @arch_dep_pkgs, $binpkg;
            }
        }
        my $dstr = join('|', map { quotemeta($_) } @arch_dep_pkgs);
        my $depregex = qr/^(?:$dstr)$/;
        for my $dbg_proc (@dbg_pkgs) {
            my $deps = $info->binary_relation($dbg_proc->pkg_name, 'strong');
            my $missing = 1;
            $missing = 0 if $deps->matches($depregex, VISIT_PRED_NAME);
            if ($missing and $dbg_proc->info->is_pkg_class('transitional')) {
                # If it is a transitional package, allow it to depend
                # on another -dbg instead.
                $missing = 0
                  if $deps->matches(qr/-dbg \Z/xsm, VISIT_PRED_NAME);
            }
            tag 'dbg-package-missing-depends', $dbg_proc->pkg_name
              if $missing;
        }

        # Check for a python*-dev build dependency in source packages that
        # build only arch: all packages.
        if ($arch_dep_packages == 0 and $build_all->implies($PYTHON_DEV)) {
            tag 'build-depends-on-python-dev-with-no-arch-any';
        }
    }

    #----- Origin

    if (defined $info->field('origin')) {
        my $origin = $info->field('origin');

        unfold('origin', \$origin);

        tag 'redundant-origin-field' if lc($origin) eq 'debian';
    }

    #----- Bugs

    if (defined $info->field('bugs')) {
        my $bugs = $info->field('bugs');

        unfold('bugs', \$bugs);

        tag 'redundant-bugs-field'
          if $bugs =~ m,^debbugs://bugs.debian.org/?$,i;
    }

    #----- Python-Version

    if (defined $info->field('python-version')) {
        my $pyversion = $info->field('python-version');

        unfold('python-version', \$pyversion);

        my @valid = (
            ['\d+\.\d+', '\d+\.\d+'],['\d+\.\d+'],
            ['\>=\s*\d+\.\d+', '\<\<\s*\d+\.\d+'],['\>=\s*\d+\.\d+'],
            ['current', '\>=\s*\d+\.\d+'],['current'],
            ['all']);

        my @pyversion = split(/\s*,\s*/, $pyversion);
        if (@pyversion > 2) {
            if (any { !/^\d+\.\d+$/ } @pyversion) {
                tag 'malformed-python-version', $pyversion;
            }
        } else {
            my $okay = 0;
            for my $rule (@valid) {
                if (
                    $pyversion[0] =~ /^$rule->[0]$/
                    && ((
                               $pyversion[1]
                            && $rule->[1]
                            && $pyversion[1] =~ /^$rule->[1]$/
                        )
                        || (!$pyversion[1] && !$rule->[1]))
                  ) {
                    $okay = 1;
                    last;
                }
            }
            tag 'malformed-python-version', $pyversion unless $okay;
        }
    }

    #----- Dm-Upload-Allowed

    if (defined $info->field('dm-upload-allowed')) {
        my $dmupload = $info->field('dm-upload-allowed');

        tag 'dm-upload-allowed-is-obsolete';

        unfold('dm-upload-allowed', \$dmupload);

        unless ($dmupload eq 'yes') {
            tag 'malformed-dm-upload-allowed', $dmupload;
        }
    }

    #----- Vcs-*

    while (my ($vcs, $splitter) = each %VCS_EXTRACT) {
        if (defined $info->field("vcs-$vcs")) {
            my $uri = $info->field("vcs-$vcs");
            unfold("vcs-$vcs", \$uri);
            my @parts = &$splitter($uri);
            if (not @parts or not $parts[0]) {
                tag 'vcs-field-uses-unknown-uri-format', "vcs-$vcs", $uri;
            } else {
                if (    $VCS_RECOMMENDED_URIS{$vcs}
                    and $parts[0] !~ $VCS_RECOMMENDED_URIS{$vcs}) {
                    if (    $VCS_VALID_URIS{$vcs}
                        and $parts[0] =~ $VCS_VALID_URIS{$vcs}) {
                        tag 'vcs-field-uses-not-recommended-uri-format',
                          "vcs-$vcs", $uri;
                    } else {
                        tag 'vcs-field-uses-unknown-uri-format', "vcs-$vcs",
                          $uri;
                    }
                }
                if (any { $_ and /\s/} @parts) {
                    tag 'vcs-field-has-unexpected-spaces', "vcs-$vcs", $uri;
                }
            }
            if ($VCS_CANONIFY{$vcs}) {
                my $canonicalized = $parts[0];
                my $tag = 'vcs-field-not-canonical';
                foreach my $canonify ($VCS_CANONIFY{$vcs}) {
                    &$canonify($canonicalized, $tag);
                }
                if ($canonicalized ne $parts[0]) {
                    tag $tag, $parts[0], $canonicalized;
                }
            }
        }
    }

    #----- Field checks (without checking the value)

    for my $field (keys %{$info->field}) {

        tag 'unknown-field-in-dsc', $field
          if ($type eq 'source' && !$SOURCE_FIELDS->known($field));

        tag 'unknown-field-in-control', $field
          if ($type eq 'binary' && !$KNOWN_BINARY_FIELDS->known($field));

        tag 'unknown-field-in-control', $field
          if ($type eq 'udeb' && !$KNOWN_UDEB_FIELDS->known($field));
    }

    return;
}

# splits "foo:bar (>= 1.2.3) [!i386 ia64] <stage1 !nocheck> <cross>" into
# ( "foo", "bar", [ ">=", "1.2.3" ], [ [ "i386", "ia64" ], 1 ], [ [ "stage1", "!nocheck" ] , [ "cross" ] ], "" )
#                                                         ^^^                                               ^^
#                     count of negated arches, if ! was given                                               ||
#                                                              rest (should always be "" for valid dependencies)
sub _split_dep {
    my $dep = shift;
    my ($pkg, $dmarch, $version, $darch, $restr)
      = ('', '', ['',''], [[], 0], []);

    my $pkgname = $1 if $dep =~ s/^\s*([^<\s\[\(]+)\s*//;
    if (defined $pkgname) {
        ($pkg, $dmarch) = split /:/, $pkgname, 2;
        $dmarch //= '';  # Ensure it is defined (in case there is no ":")
    }

    if (length $dep) {
        if ($dep
            =~ s/\s* \( \s* (<<|<=|<|=|>=|>>|>) \s* ([^\s(]+) \s* \) \s*//x) {
            @$version = ($1, $2);
        }
        if ($dep && $dep =~ s/\s*\[([^\]]+)\]\s*//) {
            my $t = $1;
            $darch->[0] = [split /\s+/, $t];
            my $negated = 0;
            for my $arch (@{ $darch->[0] }) {
                $negated++ if $arch =~ s/^!//;
            }
            $darch->[1] = $negated;
        }
        while ($dep && $dep =~ s/\s*<([^>]+)>\s*//) {
            my $t = $1;
            push @$restr, [split /\s+/, $t];
        }
    }

    return ($pkg, $dmarch, $version, $darch, $restr, $dep);
}

sub perl_core_has_version {
    my ($package, $op, $version) = @_;
    my $core_version = $PERL_CORE_PROVIDES->value($package);
    return 0 if !defined $core_version;
    return 0 unless version_check($version);
    return versions_compare($core_version, $op, $version);
}

sub unfold {
    my ($field, $line) = @_;

    $$line =~ s/\n$//;

    if ($$line =~ s/\n//g) {
        tag 'multiline-field', $field;
        # Remove leading space as it confuses some of the other checks
        # that are anchored.  This happens if the field starts with a
        # space and a newline, i.e ($ marks line end):
        #
        # Vcs-Browser: $
        #  http://somewhere.com/$
        $$line=~s/^\s*+//;
    }
    return;
}

1;

# Local Variables:
# indent-tabs-mode: nil
# cperl-indent-level: 4
# End:
# vim: syntax=perl sw=4 sts=4 sr et
