#!/usr/bin/perl -W
# fields.new -- lintian check script (rewrite)
#
# 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., 59 Temple Place - Suite 330, Boston,
# MA 02111-1307, USA.

use strict;
use lib "$ENV{'LINTIAN_ROOT'}/checks/";
use common_data;

($#ARGV == 1) or fail("syntax: deb-format <pkg> <type>");
my $pkg = shift;
my $type = shift;
my $version;

$/ = 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")) {
		print "E: $pkg $type: no-package-name\n";
	} else {
		my $name = <FH>;
		close FH;

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

#---- Version

if (not open (FH, "fields/version")) {
	print "E: $pkg $type: no-version-field\n";
} else {
	$version = <FH>;
	close FH;

	unfold("version", \$version);

	if (my ($epoch, $upstream, $debian) = _valid_version($version)) {
		if ($upstream !~ /^\d/i) {
			print "W: $pkg $type: upstream-version-not-numeric\n";
		}
	} else {
		print "E: $pkg $type: bad-version-number\n";
	}
}

#---- Architecture

if (not open (FH, "fields/architecture")) {
	print "E: $pkg $type: no-architecture-field\n";
} else {
	my $archs = <FH>;
	close FH;

	unfold("architecture", \$archs);

	my @archs = split / /, $archs;

	if (@archs > 1 && grep { $_ eq "any" || $_ eq "all" } @archs) {
		print "E: $pkg $type: magic-arch-in-arch-list\n";
	}

	for my $arch (@archs) {
		unless (grep { $_ eq $arch } qw(all alpha any arm hppa hurd-i386 i386 ia64 m68k mips mipsel powerpc s390 sh sparc)) {
			print "E: $pkg $type: unknown-architecture\n";
		}
	}

	if ($type eq "binary") {
		print "E: $pkg $type: too-many-architectures\n" if (@archs > 1);
		print "E: $pkg $type: arch-any-in-binary-pkg\n" if (grep { $_ eq "any" } @archs);
	}
}

#---- Maintainer
#---- Uploader

for my $f (qw(maintainer uploader)) {
	if (not open (FH, "fields/$f")) {
		print "E: $pkg $type: no-maintainer-field\n" if $f eq "maintainer";
	} else {
		my $maintainer = <FH>;
		close FH;

		unfold($f, \$maintainer);

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

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

#---- Source

if (not open (FH, "fields/source")) {
	print "E: $pkg $type: no-source-field\n";
} else {
	my $source = <FH>;
	close FH;

	unfold("source", \$source);

	if ($type eq 'source') {
		if ($source ne $pkg) {
			print "E: $pkg $type: source-field-does-not-match-pkg-name $_\n";
		}
	} else {
		if ($source !~ /[A-Z0-9][-+\.A-Z0-9]+                      #Package name
		                \s*                                        
		                (?:\((?:\d+:)?(?:[-\.+:A-Z0-9]+?)(?:-[\.+A-Z0-9]+)?\))?\s*$/ix) { #Version
			print "E: $pkg $type: source-field-malformed $source\n";
		}
	}	
}

#---- Essential

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

	unfold("essential", \$essential);

	print "E: $pkg $type: essential-in-source-package\n" if ($type eq "source");
	print "E: $pkg $type: essential-no-not-needed\n" if ($essential eq "no");
	print "E: $pkg $type: unknown-essential-value\n" if ($essential ne "no" && $essential ne "yes");
	print "W: $pkg $type: new-essential-package\n" if ($essential eq "yes" && ! $known_essential{$pkg});
}

#---- Section

if (not open (FH, "fields/section")) {
	print "E: $pkg $type: no-section-field\n" if $type eq "binary";
} else {
	my $section = <FH>;
	close FH;

	unfold("section", \$section);

	$section =~ s!^(non-US)/!!i;
	print "E: $pkg $type: non-us-spelling\n" if ($1 && $1 ne "non-US");
	$section =~ s!^(non-free|contrib)/!!;

	print "W: $pkg $type: unknown-section $section\n" unless $known_sections{$section};
}

#---- Priority

if (not open (FH, "fields/priority")) {
	print "E: $pkg $type: no-priority-field\n" if $type eq "binary";
} else {
	my $priority = <FH>;
	close FH;

	unfold("priority", \$priority);

	print "E: $pkg $type: unknown-priority $priority\n" if (! $known_prios{$priority});
}

#---- Package relations (binary package)

if ($type eq "binary") {
	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/;

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

			print "E: $pkg $type: alternates-not-allowed $field\n"
			    if (! grep { $_ eq $field } qw(depends pre-depends recommends suggests));

			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]};

				print "E: $pkg $type: virtual-package-depends-without-real-package-depends $field\n"
					if ($known_virtual_packages{$alternatives[0]->[0]});

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

					print "E: $pkg $type: versioned-provides $part_d_orig\n"
					    if ($field eq "provides" && $d_version->[0]);

					print "W: $pkg $type: obsolete-relation-form $part_d_orig [$field]\n"
					    if ($d_version && grep { $d_version->[0] eq $_ } qw(< >));

					print "E: $pkg $type: bad-version-in-relation $part_d_orig [$field]\n"
					    if ($d_version->[0] && ! _valid_version($d_version->[1]));

					print "W: $pkg $type: package-relation-with-self\n"
					    if $pkg eq $d_pkg;

					print "E: $pkg $type: bad-relation $part_d_orig [$field]\n"
					    if $rest;

					print "E: $pkg $type: depends-on-obsolete-package $part_d_orig [$field]\n"
					    if ($known_obsolete_packages{$d_pkg} && grep {$field eq $_} qw(depends pre-depends recommends suggest));

					print "E: $pkg $type: depends-on-essential-package-without-using-version $part_d_orig [$field]\n"
					    if ($d_pkg ne "coreutils" && $known_essential{$d_pkg});

					print "E: $pkg $type: package-depends-on-an-x-font-package $part_d_orig [$field]\n"
					    if ($field =~ /^(pre-)?depends$/ && $d_pkg =~ /^xfont.*/);

					print "E: $pkg $type: needlessly-depends-on-awk $field\n"
					    if ($d_pkg eq "awk" && $d_version->[0]);

					print "E: $pkg $type: depends-on-libdb1-compat $field\n"
					    if ($d_pkg eq "libdb1-compat" && $pkg !~ /^libc(6|6.1|0.3)/);

					print "W: $pkg $type: doc-package-depends-on-main-package $field\n"
					    if ("$d_pkg-doc" eq $pkg);
				}
			}
			print "E: $pkg $type: package-depends-on-multiple-libstdc-versions", join (" ", @seen_libstdcs), "\n"
			    if (scalar @seen_libstdcs > 1);
			print "E: $pkg $type: package-depends-on-multiple-tcl-versions", join (" ", @seen_tcls), "\n"
			    if (scalar @seen_tcls > 1);
			print "E: $pkg $type: package-depends-on-multiple-tclx-versions", join (" ", @seen_tclxs), "\n"
			    if (scalar @seen_tclxs > 1);
			print "E: $pkg $type: package-depends-on-multiple-tk-versions", join (" ", @seen_tks), "\n"
			    if (scalar @seen_tks > 1);
			print "E: $pkg $type: package-depends-on-multiple-tkx-versions", join (" ", @seen_tkxs), "\n"
			    if (scalar @seen_tkxs > 1);
			print "E: $pkg $type: package-depends-on-multiple-libpng-versions", join (" ", @seen_libpngs), "\n"
			    if (scalar @seen_libpngs > 1);
		}
	}
}

#---- Package relations (source package)

if ($type eq "source") {
	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/;

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

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

					for my $arch (@{$d_arch->[0]}) {
						print "E: $pkg $type: invalid-arch-string-in-source-relation $arch [$field: $part_d_orig]\n"
						    unless (grep { $arch eq $_ } qw(alpha arm hppa hurd-i386 i386 ia64 m68k mips mipsel powerpc s390 sh sparc));
					}

					print "E: $pkg $type: depends-on-build-essential-package-without-using-version $d_pkg [$field: $part_d_orig]\n"
					    if ($known_build_essential{$pkg} && ! $d_version->[1]);
				}
			}
		}
	}
}

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

for my $field (glob("fields/*")) {
	$field =~ s!^fields/!!;

	print "E: $pkg $type: obsolete-field\n"
	    if $known_obsolete_fields{$field};

	print "N: $pkg $type: unknown-field-in-dsc\n"
	    if ($type eq "source" && ! $known_source_fields{$field});

	print "N: $pkg $type: unknown-field-in-changes\n"
	    if ($type eq "binary" && ! $known_binary_fields{$field});
}

exit 0;

# -----------------------------------

sub fail {
	if ($_[0]) {
		warn "internal error: $_[0]\n";
	} elsif ($!) {
		warn "internal error: $!\n";
	} else {
		warn "internal error.\n";
	}
	exit 1;
}

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*//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;

	if ($ver =~ m/^(\d+:)?([-\.+:A-Z0-9]+?)(-[\.+A-Z0-9]+)?$/i) {
		return ($1, $2, $3);
	} else {
		return undef;
	}
}

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

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

	if ($$line =~ s/\n//g) {
		print "E: multiline-field $field\n";
	}
}

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

	print "E: $pkg $type: $f-address-malformed\n" if $crap;
	print "W: $pkg $type: $f-address-looks-weird\n" if ! $del;

	if (! $name) {
		print "E: $pkg $type: $f-name-missing\n";
	} elsif ($name =~ /^\S+\s+\S+/) {
		print "W: $pkg $type: $f-not-full-name\n";
	}
			
	#This should be done with Email::Valid:
	if (!$mail) {
		print "E: $pkg $type: $f-address-missing\n";
	} else {
		print STDERR $mail, "\n";
		print "E: $pkg $type: $f-address-malformed\n" 
		    unless ($mail =~ /^[^()<>@,;:\\"[\]]+@(\S+\.)+\S+/);
		
		print "W: $pkg $type: $f-address-is-on-localhost\n"
			if ($mail =~ /(?:localhost|\.localdomain|\.localnet)$/);
	}

	print "W: $pkg $type: wrong-debian-qa-address-set-as-maintainer\n"
	    if ($f eq "maintainer" && $mail eq 'debian-qa@lists.debian.org');
}