# 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 lib "$ENV{'LINTIAN_ROOT'}/checks/";
use common_data;
use Dep;
use Tags;
use Util;

# The allowed Python dependencies currently.  This is the list of alternatives
# that, either directly or through transitive dependencies that can be relied
# upon, ensure /usr/bin/python will exist for the use of dh_python.
my $python_depend = 'python | python-dev | python-all-dev';

# Certain build tools must be listed in Build-Depends even if there are no
# arch-specific packages because they're required in order to run the clean
# rule.  (See Policy 7.6.)  The following is a list of package dependencies;
# regular expressions that, if they match anywhere in the debian/rules file,
# say that this package is allowed (and required) in Build-Depends; and
# optional tags to use for reporting the problem if some information other
# than the default is required.
my @global_clean_depends = (
	[ ant => '^include\s*/usr/share/cdbs/1/rules/ant.mk' ],
	[ cdbs => '^include\s+/usr/share/cdbs/' ],
	[ dbs => '^include\s+/usr/share/dbs/' ],
	[ debhelper => '^include\s+/usr/share/cdbs/1/rules/debhelper.mk' ],
	[ dpatch => '^include\s+/usr/share/cdbs/1/rules/dpatch.mk' ],
	[ quilt => '^include\s+/usr/share/cdbs/1/rules/patchsys-quilt.mk' ],
	[ dpatch => '^include\s+/usr/share/dpatch/' ],
	[ 'quilt (>= 0.40)' => '^include\s+/usr/share/quilt/' ],
	[ $python_depend => '/usr/share/cdbs/1/class/python-distutils.mk' ],
	[ 'python-central (>= 0.5)' => '^DEB_PYTHON_SYSTEM\s*:?=\s*pycentral' ],
	[ 'python-support (>= 0.3)' => '^DEB_PYTHON_SYSTEM\s*:?=\s*pysupport' ],
);

# These are similar, but the resulting dependency is only allowed, not
# required.
#
# The xsfclean rule is specific to the packages maintained by the X Strike
# Force, but there are enough of those to make the rule worthwhile.
my @global_clean_allowed = (
	[ patchutils => '^include\s+/usr/share/cdbs/1/rules/dpatch.mk' ],
	[ patchutils => '^include\s+/usr/share/cdbs/1/rules/patchsys-quilt.mk' ],
	[ patchutils => '^include\s+/usr/share/cdbs/1/rules/simple-patchsys.mk' ],
	[ quilt => '^clean:\s+xsfclean\b' ],
);

# A list of packages; regular expressions that, if they match anywhere in the
# debian/rules file, this package must be listed in either Build-Depends or
# Build-Depends-Indep as appropriate; and optional tags as above.
my @global_depends = (
	[ $python_depend => '^\t\s*dh_python\s', 'missing-dh_python-build-dependency' ],
	[ 'debhelper (>= 5.0.31)' => '^\t\s*dh_installxfonts', 'missing-dh_installxfonts-build-dependency' ],
	[ 'python-central (>= 0.5)' => '^\t\s*dh_pycentral\s' ],
	[ 'python-support (>= 0.3)' => '^\t\s*dh_pysupport\s' ],
);

# Similarly, this list of packages, regexes, and optional tags say that if the
# regex matches in one of clean, build-arch, binary-arch, or a rule they
# depend on, this package is allowed (and required) in Build-Depends.
my @rule_clean_depends = (
	[ debhelper => '^\t\s*dh_.+' ],
	[ dpatch => '^\t\s*dpatch\s' ],
	[ "po-debconf" => '^\t\s*debconf-updatepo\s' ],
	[ $python_depend => '^\t\s*python\s' ],
	[ quilt => '^\t\s*(\S+=\S+\s+)*quilt\s' ],
	[ yada => '^\t\s*yada\s' ],
);

# Similar, but the resulting dependency is only allowed, not required.
my @rule_clean_allowed = (
	[ patch => '^\t\s*(?:perl debian/)?yada\s+unpatch' ],
	[ 'perl | perl-base (>= 5.6.0-16)' => '(^\t|\|\|)\s*(perl|\$\(PERL\))\s' ],
);

# A simple list of regular expressions which, if they match anywhere in
# debian/rules, indicate the requirements for debian/rules clean are complex
# enough that we can't know what packages are permitted in Build-Depends and
# should bypass the build-depends-without-arch-dep check completely.
my @global_clean_bypass = (
	'^include\s*/usr/share/cdbs/1/rules/ant.mk'
);

sub run {

my $pkg = shift;
my $type = shift;
my $version;
my $arch_indep;

local $/ = undef; #Read everything in one go

unless (-d "fields") {
	fail("directory in lintian laboratory for $type package $pkg missing: fields");
}

#---- Package

if ($type eq "binary"){
	if (not open (FH, "fields/package")) {
		tag "no-package-name", "";
	} else {
		my $name = <FH>;
		close FH;

		unfold("package", \$name);
	
		tag "bad-package-name", "" unless $name =~ /^[A-Z0-9][-+\.A-Z0-9]+$/i;
		tag "package-not-lowercase", "" if ($name =~ /[A-Z]/)
	}
}

#---- Version

if (not open (FH, "fields/version")) {
	tag "no-version-field", "";
} else {
	$version = <FH>;
	close FH;

	unfold("version", \$version);

	if (@_ = _valid_version($version)) {
		my ($epoch, $upstream, $debian) = @_;
		if ($upstream !~ /^\d/i) {
			tag "upstream-version-not-numeric", "$version";
		}
		if (defined $debian) {
			tag "debian-revision-should-not-be-zero", "$version"
				if $debian eq '0';
			$debian =~ /^-([^.]+)?(?:\.[^.]+)?(?:\.[^.]+)?(\..*)?$/;
			if (not defined $1 or defined $2) {
				tag "debian-revision-not-well-formed", "$version";
			}
			if ($debian =~ /^-[^.]+\.[^.]+\./ && ($type eq "source")) {
				tag "binary-nmu-debian-revision-in-source", "$version";
			}
		}
	} else {
		tag "bad-version-number", "$version";
	}
}

#---- Architecture

if (not open (FH, "fields/architecture")) {
	tag "no-architecture-field", "";
} else {
	my $archs = <FH>;
	close FH;

	unfold("architecture", \$archs);

	my @archs = split / /, $archs;

	if (@archs > 1 && grep { $_ eq "any" || $_ eq "all" } @archs) {
		tag "magic-arch-in-arch-list", "";
	}

	for my $arch (@archs) {
		if ($non_standard_archs{$arch}) {
			tag "non-standard-architecture", "$arch";
		} elsif (! $known_archs{$arch}) {
			tag "unknown-architecture", "$arch";
		}
	}

	if ($type eq "binary") {
		tag "too-many-architectures", "" if (@archs > 1);
		tag "arch-any-in-binary-pkg", "" if (grep { $_ eq "any" } @archs);
                tag "aspell-package-not-arch-all", ""
                    if ($pkg =~ /^aspell-[a-z]{2}(-.*)?$/ && (@archs > 1 || $archs[0] ne 'all'));
	}

	# Used for later tests.
	$arch_indep = 1 if (@archs == 1 && $archs[0] eq 'all');
}

#---- Subarchitecture (udeb)

if (open(FH, "fields/subarchitecture")) {
	my $subarch = <FH>;
	close(FH);

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

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

for my $f (qw(maintainer uploaders)) {
	if (not open (FH, "fields/$f")) {
		tag "no-maintainer-field", "" if $f eq "maintainer";
	} else {
		my $maintainer = <FH>;
		close FH;

		# 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);

		$maintainer =~ s/^\s*(.+?)\s*$/$1/; #Remove leading and trailing whitespace

		if ($f eq "uploaders") {
			check_maint($_, "uploader") for (split /\s*,\s*/, $maintainer);
		} else {
			check_maint($maintainer, $f);
		}
	}
}

#---- Source

if ($type eq "source") {
	if (not open (FH, "fields/source")) {
		tag "no-source-field", "";
	} else {
		my $source = <FH>;
		close FH;
	
		unfold("source", \$source);
	
		if ($type eq 'source') {
			if ($source ne $pkg) {
				tag "source-field-does-not-match-pkg-name", "$_";
			}
		} else {
			if ($source !~ /[A-Z0-9][-+\.A-Z0-9]+                      #Package name
			                \s*
			                (?:\((?:\d+:)?(?:[-\.+:A-Z0-9]+?)(?:-[\.+A-Z0-9]+)?\))?\s*$/ix) { #Version
				tag "source-field-malformed", "$source";
			}
		}	
	}
}

#---- Essential

if (open (FH, "fields/essential")) {
	my $essential = <FH>;
	close FH;

	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");
	tag "new-essential-package", "" if ($essential eq "yes" and ! $known_essential{$pkg});
}

#---- Section

if (not open (FH, "fields/section")) {
	tag "no-section-field", "" if $type eq "binary";
} else {
	my $section = <FH>;
	close FH;

	unfold("section", \$section);

	if ($type eq 'udeb') {
	    unless ($section eq 'debian-installer') {
		tag "wrong-section-for-udeb", "$section";
	    }
	} else {

	    my @parts = split /\//, $section, 2;
	    
	    if ($parts[0] =~ /non-US/i) {
		tag "non-us-spelling", "" if ($parts[0] ne "non-US");
		if ($parts[1] and not $known_non_us_parts{$parts[1]}) {
		    tag "unknown-section", "$section";
		}
	    } elsif (scalar @parts > 1) {
		tag "unknown-section", "$section" unless $known_archive_parts{$parts[0]};
		tag "unknown-section", "$section" unless $known_sections{$parts[1]};
	    } elsif ($parts[0] eq 'unknown') {
		tag "section-is-dh_make-template";
	    } else {
		tag "unknown-section", "$section" unless $known_sections{$parts[0]};
	    }
	}
}

#---- Priority

if (not open (FH, "fields/priority")) {
	tag "no-priority-field", "" if $type eq "binary";
} else {
	my $priority = <FH>;
	close FH;

	unfold("priority", \$priority);

	tag "unknown-priority", "$priority" if (! $known_prios{$priority});
}

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

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

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

if (open(FH, "fields/installer-menu-item")) {
	my $menu_item = <FH>;
	close(FH);

	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 meta-package, used for later
# dependency checks.  We consider a package to possibly be a meta-package if
# it is a binary package, arch: all, with no files outside of /usr/share/doc.
my $metapackage = 0;
if ($type eq 'binary' && $arch_indep) {
	$metapackage = 1;
	open IN, "index" or fail("cannot open index file index: $!");
	local $_;
	local $/ = "\n";
	while (<IN>) {
		my ($mode, $file) = (split(' ', $_, 6))[0,5];
		next unless $file;
		$metapackage = 0 unless ($mode =~ /^d/ || $file =~ m%^\./usr/share/doc/%);
	}
	close IN;
}
if (($type eq "binary") || ($type eq 'udeb')) {
	my (%deps, %fields);
	for my $field (qw(depends pre-depends recommends suggests conflicts provides replaces)) {
		if (open(FH, "fields/$field")) {
			#Get data and clean it
			my $data = <FH>;
			unfold($field, \$data);
			$data =~ s/^\s*(.+?)\s*$/$1/;
			$fields{$field} = $data;

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

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

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

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

				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 ($known_virtual_packages{$alternatives[0]->[0]}
					&& ($field eq "depends" || $field eq "pre-depends"));

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

					#Save the type of relationship (<<, <=, ...) and the field name:
					if (&$is_dep_field($field) && scalar @alternatives == 1) {
						$deps{$d_pkg} = [] if ! $deps{$d_pkg};
						push @{$deps{$d_pkg}}, [$field, $d_version];
					}

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

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

					tag "bad-version-in-relation", "$field: $part_d_orig"
					    if ($d_version->[0] && ! defined((_valid_version($d_version->[1]))[1]));
					
					tag "package-relation-with-self", "$field: $part_d_orig"
					    if ($pkg eq $d_pkg) && ($field ne 'conflicts');

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

					tag "depends-on-obsolete-package", "$field: $part_d_orig"
					    if ($known_obsolete_packages{$d_pkg} && &$is_dep_field($field));

					tag "depends-on-x-metapackage", "$field: $part_d_orig"
					    if ($known_x_metapackages{$d_pkg} && ! $metapackage && &$is_dep_field($field));

					tag "depends-on-essential-package-without-using-version", "$field: $part_d_orig"
					    if ($d_pkg ne "coreutils" && $known_essential{$d_pkg} && ! $d_version->[0] && &$is_dep_field($field));

					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 'xfongs-encodings');

					tag "needlessly-depends-on-awk", "$field"
					    if ($d_pkg eq "awk" && ! $d_version->[0] && &$is_dep_field($field));

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

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

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

					tag "old-versioned-python-dependency", "$field: $part_d_orig"
					    if ($d_pkg eq 'python' && $d_version->[0] eq '<<' && &$is_dep_field($field)
						&& $arch_indep && $pkg =~ /^python-/ && ! -f "fields/python-version");
				}
			}
			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 is set, make sure it's not inconsistent with the other
	# dependency fields.
	if ($fields{conflicts}) {
		for my $field (qw(depends pre-depends recommends suggests)) {
			next unless $fields{$field};
			my $depend = Dep::parse($fields{$field});
			for my $conflict (split /\s*,\s*/, $fields{conflicts}) {
				tag "conflicts-with-dependency", $conflict
				    if Dep::implies($depend, Dep::parse($conflict));
			}
		}
	}

	for my $d_pkg_name (keys %deps) {
		my $d_pkg = $deps{$d_pkg_name};
		if (scalar @$d_pkg > 1) {
			#Allow things like Depends: package1 (>= 1.3), package1 (<= 5.2)
			unless ((scalar @$d_pkg == 2) && 
			        (($d_pkg->[0]->[1]->[0] =~ />=|>>|>/ && $d_pkg->[1]->[1]->[0] =~ /<=|<<|</) or
			         ($d_pkg->[0]->[1]->[0] =~ /<=|<<|</ && $d_pkg->[1]->[1]->[0] =~ />=|>>|>/))) {
				my @relations;
				my $extra = '';
			 	if ($d_pkg->[0][0] eq $d_pkg->[1][0]) {
					$extra .= "$d_pkg->[0][0]: ";
					for (@$d_pkg) {
						if ($_->[1][0]) {
							push @relations, "$d_pkg_name (".$_->[1][0]." ".$_->[1][1].")";
						} else {
							push @relations, "$d_pkg_name";
						}
					}
				} else {
					for (@$d_pkg) {
						if ($_->[1][0]) {
							push @relations, "$_->[0]: $d_pkg_name (".$_->[1][0]." ".$_->[1][1].")";
						} else {
							push @relations, "$_->[0]: $d_pkg_name";
						}
					}
				}
				$extra .= join( ", ", @relations );
				tag "package-has-a-duplicate-relation", $extra;
			}
		}
	}
}

#---- Package relations (source package)

if ($type eq "source") {
	
	#Get number of arch-indep packages:
	my $arch_indep_packages = 0;
	my $arch_dep_packages = 0;
	if (not open(CONTROL, "debfiles/control")) {
		fail("Can't open debfiles/control: $!");
	} else {
		local $/ = "\n"; #Read this linewise
		while (<CONTROL>) {	
			if (/^Architecture: all/) {			
				$arch_indep_packages++;
			} elsif (/^Architecture:/) {		
				$arch_dep_packages++;
			}
		}
	}

	# Search through rules and determine which dependencies are required.
	# The keys in %needed and %needed_clean are the dependencies; the
	# values are the tags to use or the empty string to use the default
	# tag.
	my (%needed, %needed_clean, %allowed_clean, $bypass_needed_clean);
	open (RULES, "debfiles/rules") or fail("cannot read debfiles/rules: $!");
	my $target = "none";
	local $/ = "\n";	# Read this linewise
	my @rules = qw(clean binary-arch build-arch);
        my $maybe_skipping;
	while (<RULES>) {
		if (/^ifn?(eq|def)\s/) {
			$maybe_skipping++;
		} elsif (/^endif\s/) {
			$maybe_skipping--;
		}
		for my $rule (@global_clean_depends) {
			if ($_ =~ /$rule->[1]/) {
				if ($maybe_skipping) {
					$allowed_clean{$rule->[0]} = 1;
				} else {
					$needed_clean{$rule->[0]} = $rule->[2] || $needed_clean{$rule->[0]} || '';
				}
			}
		}
		for my $rule (@global_clean_allowed) {
			if ($_ =~ /$rule->[1]/) {
				$allowed_clean{$rule->[0]} = 1;
			}
		}
		for my $rule (@global_clean_bypass) {
			if ($_ =~ /$rule/) {
				$bypass_needed_clean = 1;
			}
		}
		for my $rule (@global_depends) {
			if ($_ =~ /$rule->[1]/ && !$maybe_skipping) {
				$needed{$rule->[0]} = $rule->[2] || $needed{$rule->[0]} || '';
			}
		}
		if (/^(\S+):(.*)/) {
			$target = $1;
			if (grep ($_ eq $target, @rules)) {
				push (@rules, split (' ', $2));
			}
		}
		if (grep ($_ eq $target, @rules)) {
			for my $rule (@rule_clean_depends) {
				if ($_ =~ /$rule->[1]/) {
					if ($maybe_skipping) {
						$allowed_clean{$rule->[0]} = 1;
					} else {
						$needed_clean{$rule->[0]} = $rule->[2] || $needed_clean{$rule->[0]} || '';
					}
				}
			}
			for my $rule (@rule_clean_allowed) {
				if ($_ =~ /$rule->[1]/) {
					$allowed_clean{$rule->[0]} = 1;
				}
			}
		}
	}
	close RULES;
	$/ = undef;             # Back to reading everything.

	tag "build-depends-indep-without-arch-indep", ""
		if (-e "fields/build-depends-indep" && $arch_indep_packages == 0);

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

	my %depend;
	for my $field (qw(build-depends build-depends-indep build-conflicts build-conflicts-indep)) {
		if (open(FH, "fields/$field")) {
			#Get data and clean it
			my $data = <FH>;
			unfold($field, \$data);
			$data =~ s/^\s*(.+?)\s*$/$1/;
			$depend{$field} = $data;

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

				tag "virtual-package-depends-without-real-package-depends", "$field: $alternatives[0]->[0]"
				    if ($known_virtual_packages{$alternatives[0]->[0]} && &$is_dep_field($field));

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

					for my $arch (@{$d_arch->[0]}) {
						if ($non_standard_archs{$arch}) {
							tag "non-standard-arch-in-source-relation", "$arch [$field: $part_d_orig]";
						} elsif (!$known_archs{$arch} && $arch ne "any" && $arch ne "all") {
							tag "invalid-arch-string-in-source-relation", "$arch [$field: $part_d_orig]"
						}
					}

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

					tag "depends-on-build-essential-package-without-using-version", "$d_pkg [$field: $part_d_orig]"
					    if ($known_build_essential{$d_pkg} && ! $d_version->[1]);

					tag "build-depends-on-essential-package-without-using-version", "$field: $part_d_orig"
					    if ($d_pkg ne "coreutils" && $known_essential{$d_pkg} && ! $d_version->[0]);
					tag "build-depends-on-obsolete-package", "$field: $part_d_orig"
					    if ($known_obsolete_packages{$d_pkg} && &$is_dep_field($field));

					tag "build-depends-on-x-metapackage", "$field: $part_d_orig"
					    if ($known_x_metapackages{$d_pkg} && &$is_dep_field($field));

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

	# Check for duplicates.
	my $build_all = $depend{'build-depends'} || '';
	$build_all .= ', ' if $depend{'build-depends'} && $depend{'build-depends-indep'};
	$build_all .= $depend{'build-depends-indep'} || '';
	my @dups = Dep::get_dups(Dep::parse($build_all));
	for my $dup (@dups) {
		tag "package-has-a-duplicate-build-relation", join (', ', @$dup);
	}

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

	# Make sure that all the required build dependencies are there.	 Don't
	# issue missing-build-dependency errors for debhelper, since there's
	# another test that does that and it would just be a duplicate.
	for my $package (keys %needed_clean) {
		my $dep = Dep::parse($package);
		my $tag = $needed_clean{$package} || 'missing-build-dependency';
		unless (Dep::implies($depend{'build-depends'}, $dep)) {
			if (Dep::implies($depend{'build-depends-indep'}, $dep)) {
				tag "build-depends-indep-should-be-build-depends", $package;
			} else {
				tag $tag, $package if $package ne 'debhelper';
			}
		}
	}
	for my $package (keys %needed) {
		my $dep = Dep::parse($package);
		my $tag = $needed{$package} || 'missing-build-dependency';
		unless (Dep::implies($depend{'build-depends'}, $dep)) {
			unless (Dep::implies($depend{'build-depends-indep'}, $dep)) {
				tag $tag, $package;
			}
		}
	}

	# This check is a bit tricky.  We want to allow in Build-Depends a
	# dependency with any version, since reporting this tag over version
	# mismatches would be confusing and quite likely wrong.	 The approach
	# taken is to strip the version information off all dependencies
	# allowed in Build-Depends, strip the version information off of the
	# dependencies in Build-Depends, and then allow any dependency in
	# Build-Depends that's implied by the dependencies we require or allow
	# there.
	#
	# We also have to map | to , when building the list of allowed
	# packages so that the implications will work properly.
	#
	# This is confusing.  There should be a better way to do this.
	if (-e "fields/build-depends" && $arch_dep_packages == 0 && !$bypass_needed_clean) {
		open(FH, "fields/build-depends") or fail("cannot read fields/build-depends: $!");
		my $build_depends = <FH>;
		close FH;
		my @packages = split /\s*,\s*/, $build_depends;
		my @allowed = map { s/[\(\[][^\)\]]+[\)\]]//g; s/\|/,/g; $_ } keys (%needed_clean), keys (%allowed_clean);
		my $dep = Dep::parse (join (',', @allowed));
		foreach my $pkg (@packages) {
			my $name = $pkg;
			$name =~ s/[\[\(][^\)\]]+[\)\]]//g;
			$name =~ s/\s+$//;
			$name =~ s/\s+/ /g;
			unless (Dep::implies($dep, Dep::parse($name))) {
				tag "build-depends-without-arch-dep", $name;
			}
		}
	}
}

#----- Origin

if (open(FH, "fields/origin")) {
	my $origin = <FH>;
	close(FH);

	unfold('origin', \$origin);

	tag "redundant-origin-field", "" if $origin =~ /^\s*debian\s*$/i;
}

#----- Bugs

if (open(FH, "fields/bugs")) {
	my $bugs = <FH>;
	close FH;

	unfold('bugs', \$bugs);

	tag "redundant-bugs-field", "" if $bugs =~ m{^\s*debbugs://bugs.debian.org/?\s*$}i;
}

#----- Python-Version

if (open(FH, "fields/python-version")) {
	my $pyversion = <FH>;
	close FH;

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

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

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

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

opendir(FIELDS, 'fields/')
	or fail("cannot read fields/ directory: $!");
for my $field (readdir FIELDS) {
	next if ($field eq '.' || $field eq '..');

	$field =~ s,:,/,g;

	tag "obsolete-field", "$field"
	    if $known_obsolete_fields{$field};

	tag "unknown-field-in-dsc", "$field"
	    if ($type eq "source" && ! $known_source_fields{$field} && ! $known_obsolete_fields{$field});

	tag "unknown-field-in-control", "$field"
	    if ($type eq "binary" && ! $known_binary_fields{$field} && ! $known_obsolete_fields{$field});

	tag "unknown-field-in-control", "$field"
	    if ($type eq "udeb" && ! $known_udeb_fields{$field} && ! $known_obsolete_fields{$field});
}
closedir(FIELDS);

}

# splits "foo (>= 1.2.3) [!i386 ia64]" into
# ( "foo", [ ">=", "1.2.3" ], [ [ "i386", "ia64" ], 1 ], "" )
#                                                  ^^^   ^^
#                                 true, if ! was given   ||
#           rest (should always be "" for valid dependencies)
sub _split_dep {
	my $dep = shift;
	my ($pkg, $version, $darch) = ("", ["",""], [[],""]);

	$pkg = $1 if $dep =~ s/^\s*([^\s\[\(]+)\s*//;

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

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

sub _valid_version {
	my $ver = shift;

	# epoch check means nothing here... This check is only useful to detect
	# weird characters in version (and to get the debian revision)
	if ($ver =~ m/^(\d+:)?([-\.+:~A-Z0-9]+?)(-[\.+~A-Z0-9]+)?$/i) {
		return ($1, $2, $3);
	} else {
		return ();
	}
}

sub unfold {
	my $field = shift;
	my $line = shift;

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

	if ($$line =~ s/\n//g) {
		tag "multiline-field", "$field";
	}
}

sub check_maint {
	my ($maintainer, $f) = @_;
	$maintainer =~ /^([^<\s]*(?:\s+[^<\s]+)*)?(\s*)(?:<(.+)>)?(.*)$/, 
	my ($name, $del, $mail, $crap) = ($1, $2, $3, $4);

	if (!$mail && $name =~ m/@/) { # name probably missing and address has no <>
		$mail = $name;
		$name = undef;
	}

	tag "$f-address-malformed", "$maintainer" if $crap;
	tag "$f-address-looks-weird", "$maintainer" if ! $del && $name && $mail;

	if (! $name) {
		tag "$f-name-missing", "$maintainer";
	} elsif ($name !~ /^\S+\s+\S+/) {
		tag "$f-not-full-name", "$name";
	}
			
	#This should be done with Email::Valid:
	if (!$mail) {
		tag "$f-address-missing", "$maintainer";
	} else {
		tag "$f-address-malformed", "$maintainer" 
		    unless ($mail =~ /^[^()<>@,;:\\"[\]]+@(\S+\.)+\S+/); #"

		tag "$f-address-is-on-localhost", "$maintainer"
		    if ($mail =~ /(?:localhost|\.localdomain|\.localnet)$/);

		tag "wrong-debian-qa-address-set-as-maintainer", "$maintainer"
		    if ($f eq "maintainer" && $mail eq 'debian-qa@lists.debian.org');

		tag "wrong-debian-qa-group-name", "$maintainer"
		    if ($f eq "maintainer" && $mail eq 'packages@qa.debian.org' &&
				$name ne 'Debian QA Group');
	}
}

1;

# vim: syntax=perl sw=4 ts=4 noet shiftround