# files -- lintian check script

# 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., 59 Temple Place - Suite 330, Boston,
# MA 02111-1307, USA.

package Lintian::files;
use strict;
use Tags;
use Util;

sub run {

my $pkg = shift;
my $type = shift;

my $file;
my $source_pkg;
my $is_python;
my $is_perl;
my $has_binary_perl_file;
my @nonbinary_perl_files_in_lib;

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> || ""));
}

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

# Read package contents...
open(IN,"index") or fail("cannot open index file index: $!");
while (<IN>) {
    chop;

    my ($perm,$owner,$size,$date,$time,$file) = split(' ', $_, 6);
    my $link;
    my $operm;

    $file =~ s,^\./,,;

    if ($file =~ s/ link to (.*)//) {
	my $link_target = $1;
	$link_target =~ s,^\./,,;
	my $link_target_dir = $link_target;
	$link_target_dir =~ s,[^/]*$,,;
	# TODO: actually, policy says 'conffile', not '/etc' -> extend!
	tag "package-contains-hardlink", $file, "->", $link_target
	    if $file =~ m,^etc/,
		or $link_target =~ m,^etc/,
		or $file !~ m,^\Q$link_target_dir\E[^/]*$,;
	next;
    } 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";
    }

    # ---------------- /etc
    if ($file =~ m,^etc/,) {
	if ($file =~ m,^etc/nntpserver, ) {
	    tag "package-uses-obsolete-file", "$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/init.d
	elsif ($file =~ m,^etc/init\.d/\S, 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";
	}
	# --------------- /etc/X11/Xresources/
	elsif ($file =~ m,^etc/X11/Xresources,) {
	    my $needs_conflicts = 1;
	    if (open(CONFLICTS, "fields/conflicts")) {
		my $line = <CONFLICTS>;
		if ($line =~ m/xbase \(.+?\)/) {
		    $needs_conflicts = 0;
		}
		close(CONFLICTS);
	    }
	    if ($needs_conflicts) {
		tag "xresources-file-in-etc-without-proper-conflicts", "$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,^-,) {
		    # exception: __init__.py files are empty tagging files (see
		    # bug #215234)
		    unless ($file =~ m,^usr/share/doc/([^/]+/)?examples/(.+/)?__init__\.py$,) {
			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/{lib,bin,include}/X11/
	elsif ($file =~ m,^usr/(?:lib|bin|include)/X11/,) {
	    tag "package-installs-file-to-usr-something-x11", "$file";
	}

	#----------------- /usr/X11R6/
	elsif ($file =~ m,^usr/X11R6/, and
	       $file !~ m,^usr/X11R6/lib/X11/fonts, and #font packages are allowed
	       $perm !~ m,^l, and #links to FHS locations are encouraged
	       $source_pkg ne "xfree86") { #The X Window System is allowed to do anything
	    tag "packages-installs-file-to-usr-x11r6", "$file";
	}

	# ---------------- /usr/lib/sgml
	elsif ($file =~ m,^usr/lib/sgml/\S,) {
	    if ($perm =~ m/^-.*[xs]/) {
		tag "executable-in-usr-lib-sgml", $file, sprintf("%04o",$operm);
	    }
	}
	# ---------------- 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 m,^usr/share/man/\S+, ) {
	    if ($type eq 'udeb') {
		tag "documentation-file", "$file";
	    }
	    if ($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
	elsif ($file =~ m,^usr/share/[^/]+$,) {
	    if ($perm =~ m/^-/) {
		tag "file-directly-in-usr-share", "$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|local|sbin|share|src|spool|tmp)/, ) {
		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.
	#
	# Other applications also use .desktop files (yay!), so we need to
	# exclude them.
	elsif ($file =~ m,/usr/share/(?:gnome/apps|applink)/[^/]+\.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";
    }
    # ---------------- /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, /usr/bin
    elsif ($file =~ m,^bin/, or $file =~ m,^usr/bin/,) {
	if ($perm =~ m/^d/ and $file =~ m,^bin/.,) {
	    tag "subdir-in-bin", "$file";
	}
    }
    # ---------------- FHS directory?
    elsif ($file =~ m,^[^/]+/$, and $file ne './' and
	   $file !~ m,^(bin|boot|dev|etc|home|lib|mnt|opt|root|sbin|tmp|usr|var)/,) { # Make an exception for the base-files package here, because it
	# installs a slew of top-level directories for setting up the
	# base system.  (Specifically, /cdrom, /floppy, /initrd, and /proc
	# are not mentioned in the FHS).
	tag "non-standard-toplevel-dir", "$file"
	    unless $pkg eq 'base-files' 
	    or $pkg eq 'hurd' 
	    or $pkg =~ /^rootskel(-bootfloppy)?/;
    }

    # ---------------- compatibility symlinks should not be used
    if ($file =~ m,^usr/(spool|tmp)/, or
	$file =~ m,^usr/(doc|bin|lib|include)/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|man|sbin|share|src|X11R6)/, or
		$file =~ m,^lib/(modules/|libc5-compat/)?, or
		$file =~ m,^var/(games|lib|www|named)/, or
		$file =~ m,^(bin|boot|dev|etc|sbin)/, or
		# non-FHS, but still usual
		$file =~ m,^usr/[^/]+-linux[^/]*/, or
		$file =~ m,^usr/iraf/,) {
	    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"
    }

    # ---------------- 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.
        # 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.
	and not $file =~ m/\.(el|c|h|py|cc|pl|pm|html|php|xpm|png)$/
        and not defined $link) {
	tag "extra-license-file", "$file";
    }


    # ---------------- plain files
    if ($perm =~ m/^-/) {
	my $wanted_operm;
	# ---------------- backup files and autosave files
	if ($file =~ /~$/ or $file =~ m,\#[^/]+\#$, or $file =~ m,/\.nfs[^/]+$,) {
	    tag "backup-file-in-package", "$file";
	}
	
	# ---------------- cvsignore files
	if ($file =~ m/\.cvsignore$/) {
	    tag "cvsignore-file-in-package", "$file";
	}

	# ---------------- subversion commit message backups
	if ($file =~ m/svn-commit.*\.tmp$/) {
	    tag "svn-commit-file-in-package", "$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);

	    $wanted_operm = 0755;

	    # 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;
		    $wanted_operm |= 04000;
		}
	    }

	    # 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;
		    $wanted_operm |= 02000;
		}
	    }

	    #allow anything with suid in the name
	    if ($pkg =~ m,-suid,) {
		undef $setuid;
		$wanted_operm |= 04000;
	    }

	    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);
	    } elsif ($operm != $wanted_operm) {
		tag "non-standard-executable-perm",
		    sprintf("$file %04o != %04o",$operm,$wanted_operm);
	    }
	}
	# ---------------- general: executable files
	elsif ($perm =~ m/[xt]/) {
	    # executable
	    if ($owner =~ m,root/games,) {
		if ($operm != 2755) {
		    tag "non-standard-executable-perm", $file,
			sprintf("%04o != 2755",$operm);
	    	}
	    } else {
		if ($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 != 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-CVS-dir", "$file";
	}
	if ($file =~ m,/\.svn/?$,) {
	    tag "package-contains-svn-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);

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

}

# translate permission strings like `-rwxrwxrwx' into an octal number
sub perm2oct {
    my ($t) = @_;

    my $o = 0;

    $t =~ m/^.(.)(.)(.)(.)(.)(.)(.)(.)(.)/;

    $o += 04000 if $3 eq 's';	# set-uid
    $o += 02000 if $6 eq 's';	# set-gid
    $o += 01000 if $9 eq 't';	# sticky bit
    $o += 00400 if $1 ne '-';	# owner read
    $o += 00200 if $2 ne '-';	# owner write
    $o += 00100 if $3 ne '-';	# owner execute
    $o += 00040 if $4 ne '-';	# owner read
    $o += 00020 if $5 ne '-';	# owner write
    $o += 00010 if $6 ne '-';	# owner execute
    $o += 00004 if $7 ne '-';	# owner read
    $o += 00002 if $8 ne '-';	# owner write
    $o += 00001 if $9 ne '-';	# owner execute

    return $o;
}

1;

# vim: syntax=perl ts=8 sw=4
