X-Git-Url: https://vcs.maemo.org/git/?a=blobdiff_plain;f=nokia-lintian%2Fchecks%2Ffiles;fp=nokia-lintian%2Fchecks%2Ffiles;h=4a177c7a7e712993d3dc8e7667584de4e74022cc;hb=1975b83207a518d59ef6b04c7c16233cb353ca86;hp=0000000000000000000000000000000000000000;hpb=208f636c44e0ec2b53c70aaed2399d8e9cf0e741;p=maemian

diff --git a/nokia-lintian/checks/files b/nokia-lintian/checks/files
new file mode 100644
index 0000000..4a177c7
--- /dev/null
+++ b/nokia-lintian/checks/files
@@ -0,0 +1,959 @@
+# files -- lintian check script -*- perl -*-
+
+# Copyright (C) 1998 Christian Schwarz and Richard Braakman
+#
+# 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::files;
+use strict;
+use Dep;
+use Tags;
+use Util;
+
+sub run {
+
+my $pkg = shift;
+my $type = shift;
+
+my $file;
+my $source_pkg = "";
+my $pkg_section = "";
+my $is_python;
+my $is_perl;
+my $has_binary_perl_file;
+my @nonbinary_perl_files_in_lib;
+
+my %is_hard_link;
+my %linked_against_libvga;
+my %script = ();
+
+# read data from objdump-info file
+open(IN, '<', "objdump-info")
+    or fail("cannot find objdump-info for $type package $pkg");
+while (<IN>) {
+    chop;
+
+    next if m/^\s*$/;
+
+    if (m,^-- (?:\./)?(\S+)\s*$,) {
+	$file = $1;
+    } elsif (m,^\s*NEEDED\s*(\S+),) {
+	my $lib = $1;
+	$linked_against_libvga{$file} = 1
+	    if $lib =~ m/libvga/;
+    }
+}
+close(IN);
+
+# Get source package name, if possible.
+if (open (SOURCE, '<', "fields/source")) {
+    chomp ($source_pkg = (<SOURCE> || ""));
+    close SOURCE;
+}
+
+# Get section.
+if (open (SECTION, '<', "fields/section")) {
+    chomp ($pkg_section = <SECTION>);
+    close SECTION;
+}
+
+# find out which files are scripts
+open(SCRIPTS, '<', "scripts") or fail("cannot open lintian scripts file: $!");
+while (<SCRIPTS>) {
+    chop;
+    m/^(\S*) (.*)$/ or fail("bad line in scripts file: $_");
+    $script{$2} = 1;
+}
+close(SCRIPTS);
+
+# We only want to warn about these once.
+my $warned_x11_predepends = 0;
+my $warned_debug_name = 0;
+
+my %dir_counts;
+my @devhelp;
+my @devhelp_links;
+
+# Read package contents...
+open(IN, '<', "index") or fail("cannot open index file index: $!");
+open(NUMERIC, '<', "index-owner-id")
+    or fail("cannot open index file index-owner-id: $!");
+while (<IN>) {
+    chop;
+
+    my ($perm,$owner,$size,$date,$time,$file) = split(' ', $_, 6);
+    my $link;
+    my $operm;
+
+    my $numeric = <NUMERIC>;
+    chop $numeric;
+    fail("cannot read index file index-owner-id") unless defined $numeric;
+    my ($owner_id, $file_chk) = (split(' ', $numeric, 6))[1, 5];
+    fail("mismatching contents of index files: $file $file_chk")
+	if $file ne $file_chk;
+
+    $file =~ s,^\./,,;
+
+    if ($file =~ s/ link to (.*)//) {
+        $is_hard_link{$file} = 1;
+	my $link_target = $1;
+	$link_target =~ s,^\./,,;
+	my $link_target_dir = $link_target;
+	$link_target_dir =~ s,[^/]*$,,;
+
+	# It may look weird to sort the file and link target here, but since
+	# it's a hard link, both files are equal and either could be
+	# legitimately reported first.	tar will generate different tar files
+	# depending on the hashing of the directory, and this sort produces
+	# stable lintian output despite that.
+	#
+	# TODO: actually, policy says 'conffile', not '/etc' -> extend!
+	tag "package-contains-hardlink", join (' -> ', sort ($file, $link_target))
+	    if $file =~ m,^etc/,
+		or $link_target =~ m,^etc/,
+		or $file !~ m,^\Q$link_target_dir\E[^/]*$,;
+    } elsif ($perm =~ m/^l/) {
+	($file, $link) = split(' -> ', $file);
+    }
+
+    $operm = perm2oct($perm);
+
+    my ($year) = ($date =~ /^(\d{4})/);
+    if ( $year <= 1984 ) { # value from dak CVS: Dinstall::PastCutOffYear
+	tag "package-contains-ancient-file", "$file $date";
+    }
+
+    my ($owner_uid, $owner_gid) = split ('/', $owner_id);
+    if (!($owner_uid < 100 || $owner_uid == 65534
+	  || ($owner_uid >= 60000 && $owner_uid < 65000))
+	|| !($owner_gid < 100 || $owner_gid == 65534
+	     || ($owner_gid >= 60000 && $owner_gid < 65000))) {
+	tag "wrong-file-owner-uid-or-gid", $file, $owner_id;
+    }
+
+    # *.devhelp and *.devhelp2 files must be accessible from a directory in
+    # the devhelp search path: /usr/share/devhelp/books and
+    # /usr/share/gtk-doc/html.  We therefore look for any links in one of
+    # those directories to another directory.  The presence of such a link
+    # blesses any file below that other directory.
+    if ($link and $file =~ m,usr/share/(devhelp/books|gtk-doc/html)/,) {
+	my $blessed = $link;
+	if ($blessed !~ m,^/,) {
+	    my $base = $file;
+	    $base =~ s,/+[^/]+$,,;
+	    while ($blessed =~ s,^\.\./,,) {
+		$base =~ s,/+[^/]+$,,;
+	    }
+	    $blessed = "$base/$blessed";
+	}
+	push (@devhelp_links, $blessed);
+    }
+
+    #count directory contents:
+    $dir_counts{$file} ||= 0 if ($perm =~ m/^d/);
+    $dir_counts{$1} = ($dir_counts{$1} || 0) + 1 if ($file =~ m,^(.+/)[^/]+/?$,);
+
+    # ---------------- /etc
+    if ($file =~ m,^etc/,) {
+	if ($file =~ m,^etc/nntpserver, ) {
+	    tag "package-uses-obsolete-file", "$file";
+	}
+	# ---------------- /etc/cron.daily, etc.
+	elsif ($file =~ m,^etc/cron\.(daily|hourly|monthly|weekly)/[^\.].*\., ) {
+	    tag "run-parts-cron-filename-contains-full-stop", "$file";
+	}
+	# ---------------- /etc/cron.d
+	elsif ($file =~ m,^etc/cron\.d/\S, and $operm != 0644) {
+	    tag "bad-permissions-for-etc-cron.d-script", sprintf("$file %04o != 0644",$operm);
+	}
+	# ---------------- /etc/emacs.*
+	elsif ($file =~ m,^etc/emacs.*/\S, and $perm =~ m/^-/
+	       and $operm != 0644) {
+	    tag "bad-permissions-for-etc-emacs-script", sprintf("$file %04o != 0644",$operm);
+	}
+	# ---------------- /etc/gconf/schemas
+	elsif ($file =~ m,^etc/gconf/schemas/\S,) {
+	    tag "package-installs-into-etc-gconf-schemas", "$file";
+	}
+	# ---------------- /etc/init.d
+	elsif ($file =~ m,^etc/init\.d/\S,
+	       and $file !~ m,^etc/init\.d/(README|skeleton)$,
+	       and $operm != 0755
+	       and $perm =~ m/^-/) {
+	    tag "non-standard-file-permissions-for-etc-init.d-script",
+		sprintf("$file %04o != 0755",$operm);
+	}
+	#----------------- /etc/pam.conf
+	elsif ($file =~ m,^etc/pam.conf, and $pkg ne "libpam-runtime" ) {
+	    tag "config-file-reserved", "$file by libpam-runtime";
+	}
+	# ---------------- /etc/rc.d
+	elsif ($type ne 'udeb' and $file =~ m,^etc/rc\.d/\S, and $pkg !~ /^(sysvinit|file-rc)$/) {
+	    tag "package-installs-into-etc-rc.d", "$file";
+	}
+	# ---------------- /etc/rc?.d
+	elsif ($type ne 'udeb' and $file =~ m,^etc/rc(\d|S)\.d/\S, and $pkg !~ /^(sysvinit|file-rc)$/) {
+	    tag "package-installs-into-etc-rc.d", "$file";
+	}
+	# ---------------- /etc/rc.boot
+	elsif ($file =~ m,^etc/rc\.boot/\S,) {
+	    tag "package-installs-into-etc-rc.boot", "$file";
+	}
+    }
+    # ---------------- /usr
+    elsif ($file =~ m,^usr/,) {
+	# ---------------- /usr/share/doc
+	if ($file =~ m,^usr/share/doc/\S,) {
+	    if ($type eq 'udeb') {
+		tag "udeb-contains-documentation-file", "$file";
+	    } else {
+		# file not owned by root?
+		if ($owner ne 'root/root') {
+		    tag "bad-owner-for-doc-file", "$file $owner != root/root";
+		}
+
+		# file directly in /usr/share/doc ?
+		if ($perm =~ m/^-/ and $file =~ m,^usr/share/doc/[^/]+$,) {
+		    tag "file-directly-in-usr-share-doc", "$file";
+		}
+
+		# executable in /usr/share/doc ?
+		if ($perm =~ m/^-.*[xs]/ and $file !~ m,^usr/share/doc/([^/]+/)?examples/,) {
+		    if ($script{$file}) {
+			tag "script-in-usr-share-doc", "$file";
+		    } else {
+			tag "executable-in-usr-share-doc", $file, (sprintf "%04o", $operm);
+		    }
+		}
+
+		# zero byte file in /usr/share/doc/
+		if ($size == 0 and $perm =~ m,^-, and not $is_hard_link{$file}) {
+		    # exception: examples may contain empty files for various reasons
+		    unless ($file =~ m,^usr/share/doc/([^/]+/)?examples/,) {
+			tag "zero-byte-file-in-doc-directory", "$file";
+		    }
+		}
+		# gzipped zero byte files:
+		# 276 is 255 bytes (maximal length for a filename) + gzip overhead
+		if ($file =~ m,.gz$, and $size <= 276 and $perm =~ m,^-,) {
+		    unless (`gzip -dc unpacked/$file`) {
+			tag "zero-byte-file-in-doc-directory", "$file";
+		    }
+		}
+
+		# override files have moved
+		my $tmp = quotemeta($pkg);
+		if ($file =~ m,^usr/share/doc/$tmp/override\.[lL]intian(\.gz)?$,) {
+		    tag "override-file-in-wrong-location", "$file";
+		} elsif ($file =~ m,^usr/share/lintian/overrides/$tmp/.*,) {
+		    tag "override-file-in-wrong-location", "$file";
+		}
+
+		# contains an INSTALL file?
+		if ($file =~ m,^usr/share/doc/$tmp/INSTALL(?:\..+)*$,) {
+		    tag "package-contains-upstream-install-documentation", "$file";
+		}
+
+		# contains a README for another distribution/platform?
+		if ($file =~ m,^usr/share/doc/$tmp/readme\.(apple|aix|atari|be|beos|bsd|bsdi|
+		                cygwin|darwin|irix|gentoo|freebsd|mac|macos|macosx|netbsd|
+				openbsd|osf|redhat|sco|sgi|solaris|suse|sun|vms|win32|win9x|
+				windows)(\.txt)?(\.gz)?$,xi){
+		    tag "package-contains-readme-for-other-platform-or-distro", "$file";
+		}
+	    }
+	}
+	# ---------------- /usr/doc
+	elsif ($file =~ m,^usr/doc/\S,) {
+	    if ($file =~ m,^usr/doc/examples/\S+, and $perm =~ m/^d/) {
+		tag "old-style-example-dir", "$file";
+	    }
+	}
+	# ---------------- /usr/X11R6/lib/X11/app-defaults
+	elsif ($file =~ m,usr/X11R6/lib/X11/app-defaults,) {
+	    tag "old-app-defaults-directory", "$file";
+	}
+
+	#----------------- /usr/{include,lib}/X11/
+	# Packages installing files here will need to pre-depend on x11-common
+	# so that the symlinks will be sorted out first on a sarge upgrade.
+	elsif ($file =~ m,^usr/(?:include|lib)/X11/,
+	       && !$warned_x11_predepends && $pkg ne 'x11-common') {
+	    my $pre_depends = '';
+	    if (open (FH, '<', "fields/pre-depends")) {
+		$pre_depends = <FH>;
+		close FH;
+		$pre_depends =~ s/\n//g;
+	    }
+	    $pre_depends = Dep::parse($pre_depends);
+	    tag "file-in-usr-something-x11-without-pre-depends", "$file"
+		unless Dep::implies($pre_depends, Dep::parse('x11-common (>= 1:7.0.0)'));
+
+	    # Always set this so that we don't redo the check, even if we
+	    # didn't warn.  If the first instance didn't warn, none will.
+	    $warned_x11_predepends = 1;
+	}
+
+	#----------------- /usr/X11R6/
+	elsif ($file =~ m,^usr/X11R6/bin, && $pkg ne 'x11-common') {
+	    tag "package-installs-file-to-usr-x11r6-bin", "$file";
+	}
+	elsif ($file =~ m,^usr/X11R6/lib/X11/fonts,) {
+	    tag "package-installs-font-to-usr-x11r6", "$file";
+	}
+	elsif ($file =~ m,^usr/X11R6/, and
+	       $perm !~ m,^l,) { #links to FHS locations are allowed
+	    tag "package-installs-file-to-usr-x11r6", "$file";
+	}
+
+	# ---------------- /usr/lib/debug
+	elsif ($file =~ m,^usr/lib/debug/\S,) {
+	    unless ($warned_debug_name) {
+		tag "debug-package-should-be-named-dbg", "$file"
+		    unless ($pkg =~ /-dbg$/);
+		$warned_debug_name = 1;
+	    }
+	}
+
+	# ---------------- /usr/lib/sgml
+	elsif ($file =~ m,^usr/lib/sgml/\S,) {
+	    tag "file-in-usr-lib-sgml", $file;
+	}
+	# ---------------- perllocal.pod
+	elsif ($file =~ m,^usr/lib/perl.*/perllocal.pod$,) {
+	    tag "package-installs-perllocal-pod", "$file";
+	}
+	# ---------------- .packlist files
+	elsif ($file =~ m,^usr/lib/perl.*/.packlist$,) {
+	    tag "package-installs-packlist", "$file";
+	}
+	elsif ($file =~ m,^usr/lib/perl5/.*\.(pl|pm)$,) {
+	    push @nonbinary_perl_files_in_lib, $file;
+	}
+	elsif ($file =~ m,^usr/lib/perl5/.*\.(bs|so)$,) {
+	    $has_binary_perl_file = 1;
+	}
+	# ---------------- /usr/lib -- needs to go after the other usr/lib/*
+	elsif ($file =~ m,^usr/lib/,) {
+	    if ($type ne 'udeb' and $file =~ m,\.(gif|jpeg|jpg|png|tiff|xpm|xbm)$, and not defined $link) {
+		tag "image-file-in-usr-lib", "$file"
+	    }
+	}
+	# ---------------- /usr/local
+	elsif ($file =~ m,^usr/local/\S+,) {
+	    if ($perm =~ m/^d/) {
+		tag "dir-in-usr-local", "$file";
+	    } else {
+		tag "file-in-usr-local", "$file";
+	    }
+	}
+	# ---------------- /usr/share/man and /usr/X11R6/man
+	elsif ($file =~ m,^usr/X11R6/man/\S+, or $file =~ m,^usr/share/man/\S+,) {
+	    if ($type eq 'udeb') {
+		tag "documentation-file", "$file";
+	    }
+	    if ($perm =~ m/^d/) {
+		tag "stray-directory-in-manpage-directory", "$file"
+		    if ($file !~ m,^usr/(X11R6|share)/man/(?:[^/]+/)?(man\d/)?$,);
+	    } elsif ($perm =~ m/^-.*[xt]/) {
+		tag "executable-manpage", "$file";
+	    }
+	}
+	# ---------------- /usr/share/info
+	elsif ($file =~ m,^usr/share/info\S+,) {
+	    if ($type eq 'udeb') {
+		tag "documentation-file", "$file";
+	    }
+	}
+	# ---------------- /usr/share/linda/overrides
+	elsif ($file =~ m,^usr/share/linda/overrides/\S+,) {
+	    tag "package-contains-linda-override", $file;
+	}
+	# ---------------- /usr/share
+	elsif ($file =~ m,^usr/share/[^/]+$,) {
+	    if ($perm =~ m/^-/) {
+		tag "file-directly-in-usr-share", "$file";
+	    }
+	}
+        # ---------------- /usr/bin
+	elsif ($file =~ m,^usr/bin/,) {
+	    if ($perm =~ m/^d/ and $file =~ m,^usr/bin/., and $file !~ m,^usr/bin/(X11|mh)/,) {
+		tag "subdir-in-usr-bin", "$file";
+	    }
+	}
+	# ---------------- /usr subdirs
+	elsif ($type ne 'udeb' and $file =~ m,^usr/[^/]+/$,) { # FSSTND dirs
+	    if ( $file =~ m,^usr/(dict|doc|etc|info|man|adm|preserve)/,) {
+		tag "FSSTND-dir-in-usr", "$file";
+	    }
+	    # FHS dirs
+	    elsif ($file !~ m,^usr/(X11R6|X386|
+				    bin|games|include|
+				    lib|lib32|lib64|
+				    local|sbin|share|
+				    src|spool|tmp)/,x) {
+		tag "non-standard-dir-in-usr", "$file";
+	    } elsif ($file =~ m,^usr/share/doc,) {
+		tag "uses-FHS-doc-dir", "$file";
+	    }
+
+	    # unless $file =~ m,^usr/[^/]+-linuxlibc1/,; was tied into print
+	    # above...
+	    # Make an exception for the altdev dirs, which will go away
+	    # at some point and are not worth moving.
+	}
+	# ---------------- .desktop files
+	# People have placed them everywhere, but nowadays the consensus seems
+	# to be to stick to the fd.org standard drafts, which says that
+	# .desktop files intended for menus should be placed in
+	# $XDG_DATA_DIRS/applications.  The default for $XDG_DATA_DIRS is
+	# /usr/local/share/:/usr/share/, according to the basedir-spec on
+	# fd.org. As distributor, we should only allow /usr/share.
+	#
+	# KDE hasn't moved its files from /usr/share/applnk, so don't warn
+	# about this yet until KDE adopts the new location.
+	elsif ($file =~ m,^usr/share/gnome/apps/.*\.desktop$,) {
+	    tag "desktop-file-in-wrong-dir", $file;
+	}
+
+    }
+    # ---------------- /var subdirs
+    elsif ($type ne 'udeb' and $file =~ m,^var/[^/]+/$,) { # FSSTND dirs
+	if ( $file =~ m,^var/(adm|catman|named|nis|preserve)/, ) {
+	    tag "FSSTND-dir-in-var", "$file";
+	}
+	# FHS dirs with exception in Debian policy
+	elsif ( $file !~ m,^var/(account|lib|cache|crash|games|lock|log|opt|run|spool|state|tmp|www|yp)/,) {
+	    tag "non-standard-dir-in-var", "$file";
+	}
+    }
+    elsif ($type ne 'udeb' and $file =~ m,^var/lib/games/.,) {
+	tag "non-standard-dir-in-var", "$file";
+    }
+    # ---------------- /var/www
+    # Packages are allowed to create /var/www since it's historically been the
+    # default document root, but they shouldn't be installing stuff under that
+    # directory.
+    elsif ($file =~ m,^var/www/\S+,) {
+	tag "dir-or-file-in-var-www", $file;
+    }
+    # ---------------- /opt
+    elsif ($file =~ m,^opt/.,) {
+	tag "dir-or-file-in-opt", "$file";
+    }
+    elsif ($file =~ m,^hurd/.,) {
+	next;
+    } elsif ($file =~ m,^server/.,) {
+	next;
+    }
+    # ---------------- /tmp, /var/tmp, /usr/tmp
+    elsif ($file =~ m,^tmp/., or $file =~ m,^(var|usr)/tmp/.,) {
+	tag "dir-or-file-in-tmp", "$file";
+    }
+    # ---------------- /mnt
+    elsif ($file =~ m,^mnt/.,) {
+	tag "dir-or-file-in-mnt", "$file";
+    }
+    # ---------------- /bin
+    elsif ($file =~ m,^bin/,) {
+	if ($perm =~ m/^d/ and $file =~ m,^bin/.,) {
+	    tag "subdir-in-bin", "$file";
+	}
+    }
+    # ---------------- /srv
+    elsif ($file =~ m,^srv/.,) {
+	tag "dir-or-file-in-srv", "$file";
+    }
+    # ---------------- FHS directory?
+    elsif ($file =~ m,^[^/]+/$, and $file ne './' and
+	   $file !~ m,^(bin|boot|dev|etc|home|lib(64|32)?|mnt|opt|root|sbin|srv|tmp|usr|var)/,) {
+	# Make an exception for the base-files package here and other similar
+	# packages because they install a slew of top-level directories for
+	# setting up the base system.  (Specifically, /cdrom, /floppy,
+	# /initrd, and /proc are not mentioned in the FHS).
+	#
+	# Also make an exception for /emul, which is used for multiarch
+	# support in Debian at the moment.
+	tag "non-standard-toplevel-dir", "$file"
+	    unless $pkg eq 'base-files'
+		or $pkg eq 'hurd'
+		or $pkg =~ /^rootskel(-bootfloppy)?/
+		or $file =~ m,^emul/,;
+    }
+
+    # ---------------- compatibility symlinks should not be used
+    if ($file =~ m,^usr/(spool|tmp)/, or
+	$file =~ m,^usr/(doc|bin)/X11/, or
+	$file =~ m,^var/adm/,) {
+	tag "use-of-compat-symlink", "$file";
+    }
+
+    # ---------------- .ali files (Ada Library Information)
+    if ($file =~ m,^usr/lib/.*\.ali$, && $operm != 0444) {
+	tag "bad-permissions-for-ali-file", "$file";
+    }
+
+    # ---------------- any files
+    if ($perm !~ m/^d/) {
+	unless ($type eq 'udeb'
+		or $file =~ m,^usr/(bin|dict|doc|games|
+				    include|info|lib(32|64)?|
+				    man|sbin|share|src|X11R6)/,x
+		or $file =~ m,^lib(32|64)?/(modules/|libc5-compat/)?,
+		or $file =~ m,^var/(games|lib|www|named)/,
+		or $file =~ m,^(bin|boot|dev|etc|sbin)/,
+		# non-FHS, but still usual
+		or $file =~ m,^usr/[^/]+-linux[^/]*/,
+		or $file =~ m,^usr/iraf/,
+		or $file =~ m,^emul/ia32-linux/(lib|usr/lib)/,) {
+	    tag "file-in-unusual-dir", "$file";
+	}
+    }
+
+    # ---------------- .pyc (compiled python files
+    if ($file =~ m,^usr/lib/python\d\.\d/.*.pyc$,) {
+	tag "package-installs-python-pyc", "$file"
+    }
+
+    # ---------------- /usr/lib/site-python
+    if ($file =~ m,^usr/lib/site-python/\S,) {
+	tag "file-in-usr-lib-site-python", "$file";
+    }
+
+    # ---------------- pythonX.Y extensions
+    if ($file =~ m,^usr/lib/python\d\.\d/\S,
+	and not $file =~ m,^usr/lib/python\d\.\d/site-packages/,) {
+        # check if it's one of the Python proper packages
+	unless (defined $is_python) {
+	    $is_python = 0;
+	    if (open(SOURCE, '<', "fields/source")) {
+		$_ = <SOURCE>;
+		$is_python = 1 if /^python(\d\.\d)?($|\s)/;
+		close(SOURCE);
+	    }
+	}
+	tag "third-party-package-in-python-dir", "$file"
+	    unless $is_python;
+    }
+    # ---------------- perl modules
+    if ($file =~ m,^usr/(share|lib)/perl/\S,) {
+       # check if it's the "perl" package itself
+       unless (defined $is_perl) {
+           $is_perl = 0;
+           if (open(SOURCE, '<', "fields/source")) {
+               $_ = <SOURCE>;
+               $is_perl = 1 if /^perl($|\s)/;
+               close(SOURCE);
+           }
+       }
+       tag "perl-module-in-core-directory", "$file"
+           unless $is_perl;
+    }
+
+    # ---------------- license files
+    if ($file =~ m,(copying|licen[cs]e)(\.[^/]+)?$,i
+	# Ignore some common extensions; there was at least one file named
+	# "license.el".  These are probably license-displaying code, not
+	# license files.  Also ignore binaries in /usr/bin and friends.
+	#
+	# Another exception is made for .html and .php because preserving
+	# working links is more important than saving some bytes, and
+	# because a package had a HTML form for licenses called like that.
+	# Another exception is made for various picture formats since
+	# those are likely to just be simply pictures.
+	#
+	# DTD files are excluded at the request of the Mozilla suite
+	# maintainers.	Zope products include license files for runtime
+	# display.  underXXXlicense.docbook files are from KDE.
+	#
+	# Ignore extra license files in examples, since various package
+	# building software includes example packages with licenses.
+	and not $file =~ m/\.(el|c|h|py|cc|pl|pm|html|php|rb|xpm|png|jpe?g|gif|svg|dtd)$/
+	and not $file =~ m,^usr/share/zope/Products/.*\.(dtml|pt|cpt)$,
+	and not $file =~ m,/under\S+License\.docbook$,
+	and not $file =~ m,^(usr/)?s?bin/,
+	and not $file =~ m,^usr/share/doc/[^/]+/examples/,
+	and not defined $link) {
+	tag "extra-license-file", "$file";
+    }
+
+    # ---------------- .devhelp2? files
+    if ($file =~ m,\.devhelp2?(\.gz)?$,
+	# If the file is located in a directory not searched by devhelp, we
+	# check later to see if it's in a symlinked directory.
+	and not $file =~ m,^usr/share/(devhelp/books|gtk-doc/html)/,
+	and not $file =~ m,^usr/share/doc/[^/]+/examples/,) {
+	push (@devhelp, $file);
+    }
+
+    # ---------------- weird file names
+    if ($file =~ m,\s+\z,) {
+	tag "file-name-ends-in-whitespace", "$file";
+    }
+
+    # ---------------- plain files
+    if ($perm =~ m/^-/) {
+	my $wanted_operm;
+	# ---------------- backup files and autosave files
+	if ($file =~ /~$/ or $file =~ m,\#[^/]+\#$, or $file =~ m,/\.[^/]+\.swp$,) {
+	    tag "backup-file-in-package", "$file";
+	}
+	if ($file =~ m,/\.nfs[^/]+$,) {
+	    tag "nfs-temporary-file-in-package", "$file";
+	}
+
+	# ---------------- vcs control files
+	if ($file =~ m/\.((cvs|git|hg)ignore|arch-inventory|hgtags|hg_archival\.txt)$/) {
+	    tag "package-contains-vcs-control-file", "$file";
+	}
+
+	# ---------------- subversion and svk commit message backups
+	if ($file =~ m/svn-commit.*\.tmp$/) {
+	    tag "svn-commit-file-in-package", "$file";
+	}
+	if ($file =~ m/svk-commit.+\.tmp$/) {
+	    tag "svk-commit-file-in-package", "$file";
+	}
+
+	# ---------------- executables with language extensions
+	if ($file =~ m,^(usr/)?(s?bin|games)/[^/]+\.(pl|sh|py|php|rb|tcl|bsh|csh|tcl)$,) {
+	    tag "script-with-language-extension", "$file";
+	}
+
+	# ---------------- Autogenerated databases from other OSes
+	if ($file =~ m,/Thumbs\.db(\.gz)?$,i) {
+	    tag "windows-thumbnail-database-in-package", "$file";
+	}
+	if ($file =~ m,/\.DS_Store(\.gz)?$,) {
+	    tag "macos-ds-store-file-in-package", "$file";
+	}
+	if ($file =~ m,/\._[^_/][^/]*$, and $file !~ m/\.swp$/) {
+	    tag "macos-resource-fork-file-in-package", "$file";
+	}
+
+	# ---------------- embedded Javascript libraries
+	if ($file =~ m,/(mochikit|
+			 jquery(\.(min|lite|pack))?|
+			 prototype(-[\d\.]+)?|
+			 scriptaculous|
+			 fckeditor|
+			 cropper(\.uncompressed)?
+			)\.js(\.gz)?$,ix) {
+	    tag "embedded-javascript-library", "$file";
+	}
+
+	# ---------------- general: setuid/setgid files!
+	if ($perm =~ m/s/) {
+	    my ($setuid, $setgid) = ("","");
+	    # get more info:
+	    my ($user,$group) = ("", "");
+
+	    if ($owner =~ m,^(.*)/(.*)$,) {
+		$user = $1;
+		$group = $2;
+	    }
+	    $setuid = $user if ($operm & 04000);
+	    $setgid = $group if ($operm & 02000);
+
+	    # 1st special case: program is using svgalib:
+	    if (exists $linked_against_libvga{$file}) {
+		# setuid root is ok, so remove it
+		if ($setuid eq 'root') {
+		    undef $setuid;
+		}
+	    }
+
+	    # 2nd special case: program is a setgid game
+	    if ($file =~ m,usr/lib/games/\S+, or $file =~ m,usr/games/\S+,) {
+		# setgid games is ok, so remove it
+		if ($setgid eq 'games') {
+		    undef $setgid;
+		}
+	    }
+
+	    # 3rd special case: allow anything with suid in the name
+	    if ($pkg =~ m,-suid,) {
+		undef $setuid;
+	    }
+
+	    # Check for setuid and setgid that isn't expected.
+	    if ($setuid and $setgid) {
+		tag "setuid-gid-binary", $file, sprintf("%04o $owner",$operm);
+	    } elsif ($setuid) {
+		tag "setuid-binary", $file, sprintf("%04o $owner",$operm);
+	    } elsif ($setgid) {
+		tag "setgid-binary", $file, sprintf("%04o $owner",$operm);
+	    }
+
+	    # Check for permission problems other than the setuid status.
+	    if (($operm & 0444) != 0444) {
+		tag "executable-is-not-world-readable", $file,
+		    sprintf("%04o",$operm);
+	    } elsif ($operm != 04755 && $operm != 02755 && $operm != 06755 && $operm != 04754) {
+		tag "non-standard-setuid-executable-perm", $file,
+		    sprintf("%04o",$operm);
+	    }
+	}
+	# ---------------- general: executable files
+	elsif ($perm =~ m/[xt]/) {
+	    # executable
+	    if ($owner =~ m,root/games,) {
+		if ($operm != 2755) {
+		    tag "non-standard-game-executable-perm", $file,
+			sprintf("%04o != 2755",$operm);
+	    	}
+	    } else {
+		if (($operm & 0444) != 0444) {
+		    tag "executable-is-not-world-readable", $file,
+			sprintf("%04o != 0755",$operm);
+		} elsif ($operm != 0755) {
+		    tag "non-standard-executable-perm", $file,
+			sprintf("%04o != 0755",$operm);
+		}
+	    }
+	}
+	# ---------------- general: normal (non-executable) files
+	else {
+	    # not executable
+	    # special case first: game data
+	    if ($operm == 0664 and $owner =~ m,root/games, and
+		$file =~ m,var/(lib/)?games/\S+,) {
+		# everything is ok
+	    } elsif ($operm == 0444 and $file =~ m,usr/lib/.*\.ali$,) {
+		# Ada library information files should be read-only
+		# since GNAT behaviour depends on that
+		# everything is ok
+	    } elsif ($operm == 0600 and $file =~ m,etc/backup.d/,) {
+		# backupninja expects configurations files to be 0600
+	    } elsif ($operm != 0644) {
+		tag "non-standard-file-perm", $file,
+		    sprintf("%04o != 0644",$operm);
+	    }
+	}
+    }
+    # ---------------- directories
+    elsif ($perm =~ m/^d/) {
+	# special cases first:
+        # game directory with setgid bit
+	if ($file =~ m,var/(lib/)?games/\S+, and $operm == 02775
+            and $owner =~ m,root/games,) {
+            # do nothing, this is allowed, but not mandatory
+        }
+	# otherwise, complain if it's not 0755.
+	elsif ($operm != 0755) {
+	    tag "non-standard-dir-perm", $file,
+		sprintf("%04o != 0755", $operm);
+	}
+	if ($file =~ m,/CVS/?$,) {
+	    tag "package-contains-vcs-control-dir", "$file";
+	}
+	if ($file =~ m,/\.(svn|bzr|git|hg)/?$,) {
+	    tag "package-contains-vcs-control-dir", "$file";
+	}
+	if (($file =~ m,/\.arch-ids/?$,)
+	    || ($file =~ m,/\{arch\}/?$,)) {
+	    tag "package-contains-vcs-control-dir", "$file";
+	}
+	if ($file =~ m,/\.(be|ditrack)/?$,) {
+	    tag "package-contains-bts-control-dir", "$file";
+	}
+	if ($file =~ m,/.xvpics/?$,) {
+	    tag "package-contains-xvpics-dir", "$file";
+	}
+	if ($file =~ m,usr/share/doc/[^/]+/examples/examples/?$,) {
+	    tag "nested-examples-directory", "$file";
+	}
+    }
+    # ---------------- symbolic links
+    elsif ($perm =~ m/^l/) {
+	# link
+
+	my $mylink = $link;
+	if ($mylink =~ s,//+,/,g) {
+	    tag "symlink-has-double-slash", "$file $link";
+	}
+	if ($mylink =~ s,(.)/$,$1,) {
+	    tag "symlink-ends-with-slash", "$file $link";
+	}
+
+	# determine top-level directory of file
+	$file =~ m,^/?([^/]*),;
+	my $filetop = $1;
+
+	if ($mylink =~ m,^/([^/]*),) {
+	    # absolute link, including link to /
+
+	    # determine top-level directory of link
+	    $mylink =~ m,^/([^/]*),;
+	    my $linktop = $1;
+
+	    if ($type ne 'udeb' and $filetop eq $linktop) {
+		# absolute links within one toplevel directory are _not_ ok!
+		tag "symlink-should-be-relative", "$file $link";
+	    }
+
+	    # Any other case is already definitely non-recursive
+	    tag "symlink-is-self-recursive", "$file $link"
+	    	if $mylink eq '/';
+
+	} else {
+	    # relative link, we can assume from here that the link starts nor
+	    # ends with /
+
+	    my @filecomponents = split('/', $file);
+	    # chop off the name of the symlink
+	    pop @filecomponents;
+
+	    my @linkcomponents = split('/', $mylink);
+
+	    # handle `../' at beginning of $link
+	    my $lastpop = undef;
+	    my $linkcomponent = undef;
+	    while ($linkcomponent = shift @linkcomponents) {
+		if ($linkcomponent eq '.') {
+		    tag "symlink-contains-spurious-segments", "$file $link"
+		    	unless $mylink eq '.';
+		    next;
+		}
+		last if $linkcomponent ne '..';
+		if (@filecomponents) {
+		    $lastpop = pop @filecomponents;
+		} else {
+		    tag "symlink-has-too-many-up-segments", "$file $link";
+		    goto NEXT_LINK;
+		}
+	    }
+
+	    if (!defined $linkcomponent) {
+		# After stripping all starting .. components, nothing left
+		tag "symlink-is-self-recursive", "$file $link";
+	    }
+
+	    # does the link go up and then down into the same directory?
+	    # (lastpop indicates there was a backref at all, no linkcomponent
+	    # means the symlink doesn't get up anymore)
+	    if (defined $lastpop && defined $linkcomponent &&
+		$linkcomponent eq $lastpop) {
+		tag "lengthy-symlink", "$file $link";
+	    }
+
+	    if ($#filecomponents == -1) {
+		# we've reached the root directory
+		if (($type ne 'udeb') 
+		    && (!defined $linkcomponent)
+		    || ($filetop ne $linkcomponent)) {
+		    # relative link into other toplevel directory.
+		    # this hits a relative symbolic link in the root too.
+		    tag "symlink-should-be-absolute", "$file $link";
+		}
+	    }
+
+	    # check additional segments for mistakes like `foo/../bar/'
+	    foreach (@linkcomponents) {
+		if ($_ eq '..' || $_ eq '.') {
+		    tag "symlink-contains-spurious-segments", "$file $link";
+		    last;
+		}
+	    }
+	}
+    NEXT_LINK:
+
+	if ($link =~ m,\.(gz|z|Z|bz|bz2|tgz|zip)\s*$,) {
+	    # symlink is pointing to a compressed file
+
+	    # symlink has correct extension?
+	    unless ($file =~ m,\.$1\s*$,) {
+		tag "compressed-symlink-with-wrong-ext", "$file $link";
+	    }
+	}
+    }
+    # ---------------- special files
+    else {
+	# special file
+	tag "special-file", $file, sprintf("%04o",$operm);
+    }
+}
+close(IN);
+
+fail("mismatching contents of index files") if defined <NUMERIC>;
+close(NUMERIC);
+
+#check for sect: games but nothing in /usr/games. Check for any binary to
+#save ourselves from game-data false positives:
+if ($pkg_section =~ m,games$,
+    and (($dir_counts{"usr/games/"} || 0) == 0)
+    and (($dir_counts{"bin/"} || 0) + ($dir_counts{"usr/bin/"} || 0)) > 0) {
+    tag "package-section-games-but-contains-no-game";
+}
+
+if ($pkg_section =~ m,games$,
+    and (($dir_counts{"usr/games/"} || 0)> 0)
+    and (($dir_counts{"bin/"} || 0) + ($dir_counts{"usr/bin/"} || 0)) > 0) {
+    tag "package-section-games-but-has-usr-bin";
+}
+
+# Warn about empty directories, but ignore empty directories in /var (packages
+# create directories to hold dynamically created data) or /etc (configuration
+# files generated by maintainer scripts).  Also skip base-files, which is a
+# very special case.
+#
+# Empty Perl directories are an ExtUtils::MakeMaker artifact that will be
+# fixed in Perl 5.10, and people can cause more problems by trying to fix it,
+# so just ignore them.
+#
+# python-support needs a directory for each package even it might be empty
+foreach my $dir (keys %dir_counts) {
+    next if $dir eq "";
+    next if ($dir =~ m{^var/} or $dir =~ m{^etc/});
+    next if $pkg eq 'base-files';
+    if ($dir_counts{$dir} == 0) {
+	if ($dir ne 'usr/lib/perl5/'
+	    and $dir ne 'usr/share/perl5/'
+	    and $dir !~ m;^usr/share/python-support/;) {
+	    tag "package-contains-empty-directory", $dir;
+	}
+    }
+}
+
+if (!$has_binary_perl_file && @nonbinary_perl_files_in_lib) {
+    foreach my $file (@nonbinary_perl_files_in_lib) {
+	tag "package-installs-nonbinary-perl-in-usr-lib-perl5", "$file";
+    }
+}
+
+# Check for .devhelp2? files that aren't symlinked into paths searched by
+# devhelp.
+for my $file (@devhelp) {
+    my $found = 0;
+    for my $link (@devhelp_links) {
+	if ($file =~ m,^\Q$link,) {
+	    $found = 1;
+	    last;
+	}
+    }
+    tag 'package-contains-devhelp-file-without-symlink', $file unless $found;
+}
+
+}
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: t
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl ts=8 sw=4