#!/usr/bin/perl
# files -- lintian check script

# Copyright (C) 1998 by 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.

($#ARGV == 1) or fail("syntax: files <pkg> <type>");
$pkg = shift;
$type = shift;

# build list of exceptions to 'name-space-pollution'
for (qw(at ar as bc bg cc cd cp cu dd df du ed ex fc fg id ln lp ls m4
	mv nl nm od pg pr ps rm sh tr vi wc ci co dc ld su w)) {
  $legal_name{$_} = 1;
}
$legal_name{'['} = 1;

# 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 /^\s*$/;

    if (/^-- (\S+)\s*$/) {
	$file = $1;
    } elsif (/^\s*NEEDED\s*(\S+)/) {
	$lib = $1;
	$linked_against_libvga{$file} = 1
	    if $lib =~ /libvga/;
    }
}
close(IN);
  
# 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);
    $file =~ s/ link to .*//;

    my $link;
    if ($perm =~ /^l/) {
	($file, $link) = split(' -> ', $file);
    }

    my $operm = perm2oct($perm);

    # ---------------- /etc
    if ($file =~ m,^etc/,) {

	# ---------------- /etc/cron.d
	if ($file =~ m,^etc/cron\.d/\S, and $operm != 0644) {
	    print "E: $pkg $type: bad-permissions-for-etc-cron.d-script $file $operm != 0644\n";
	}

	# ---------------- /etc/emacs.*
	if ($perm =~ /^-/ and $file =~ m,^etc/emacs.*/\S, and $operm != 0644) {
	    printf "E: $pkg $type: bad-permissions-for-etc-emacs-script $file %04o != 0644\n",$operm;
	}
    
	# ---------------- /etc/init.d
	if ($file =~ m,^etc/init\.d/\S, and $operm != 0755) {
	    printf "E: $pkg $type: non-standard-file-permissions-for-etc-init.d-script $file %04o != 0755\n",$operm;
	}

	# ---------------- /etc/rc.d
	if ($file =~ m,^etc/rc\.d/\S,) {
	    print "E: $pkg $type: package-installs-into-etc-rc.d $file\n";
	}

	# ---------------- /etc/rc.boot
	if ($file =~ m,^etc/rc\.boot/\S,) {
	    print "E: $pkg $type: package-installs-into-etc-rc.boot $file\n";
	}
    }
    # ---------------- /usr
    elsif ($file =~ m,^usr/,) {

	# ---------------- /usr/doc
	if ($file =~ m,^usr/doc/\S,) {
	    print "E: $pkg $type: bad-owner-for-doc-file $file $owner != root/root\n"
		if $owner ne 'root/root';

	    # file directly in /usr/doc ?
	    if ($perm =~ /^-/ and $file =~ m,^usr/doc/[^/]+$,) {
		print "E: $pkg $type: file-directly-in-usr-doc $file\n";
	    }

	    # executable in /usr/doc ?
	    if ($perm =~ /^-.*[xs]/ and $file !~ m,^usr/doc/([^/]+/)?examples/,) {
		printf "E: $pkg $type: executable-in-usr-doc $file %04o\n",$operm;
	    }
      
	    # dir in /usr/doc/examples ?
	    if ($file =~ m,^usr/doc/examples/\S+, and $perm =~ /^d/) {
		print "E: $pkg $type: old-style-example-dir $file\n";
	    }
	}
	# ---------------- /usr/lib/sgml
	elsif ($file =~ m,^usr/lib/sgml/\S,) {
	    if ($perm =~ /^-.*[xs]/) {
		printf "E: $pkg $type: executable-in-usr-lib-sgml $file %04o\n",$operm;
	    }
	}
	# ---------------- perllocal.pod
	elsif ($file =~ m,^usr/lib/perl.*/perllocal.pod$,) {
	    print "E: $pkg $type: package-installs-perllocal-pod $file\n";
	}
	# ---------------- /usr/local
	elsif ($file =~ m,^usr/local/\S+,) {
	    if ($perm =~ /^d/) {
		print "E: $pkg $type: dir-in-usr-local $file\n";
	    } else {
		print "E: $pkg $type: file-in-usr-local $file\n";
	    }
	}
	# ---------------- /usr/man and /usr/X11R6/man
	elsif ($file =~ m,^usr(/X11R6)?/man/\S+,) {
	    if ($perm =~ /^-.*[xt]/) {
		print "E: $pkg $type: executable-manpage $file\n";
	    }
	}
	# ---------------- /usr/share
	elsif ($file =~ m,^usr/share/[^/]+$,) {
	    if ($perm =~ /^-/) {
		print "E: $pkg $type: file-directly-in-usr-share $file\n";
	    }
	}
    }
    # ---------------- /opt
    elsif ($file =~ m,^opt/,) {
	print "E: $pkg $type: dir-or-file-in-opt $file\n";
    }
    # ---------------- /tmp, /var/tmp, /usr/tmp
    elsif ($file =~ m,^tmp/, or $file =~ m,^var/tmp/, or $file =~ m,^usr/tmp/,) {
	print "E: $pkg $type: dir-or-file-in-tmp $file\n";
    }
  
    # ---------------- any binaries
# disabled tag since policy is not defined yet:
#    if (($file =~ m,^(bin/)(\S\S?)(\s|\Z),o) or
# 	($file =~ m,^(sbin/)(\S\S?)(\s|\Z),o) or
# 	($file =~ m,^(usr/bin/)(\S\S?)(\s|\Z),o) or
# 	($file =~ m,^(usr/sbin/)(\S\S?)(\s|\Z),o) or
# 	($file =~ m,^(usr/games/)(\S\S?)(\s|\Z),o) ) {
# 	unless ($legal_name{$2}) {
# 	    print "W: $pkg $type: possible-name-space-pollution $1$2\n";
# 	}
#     }

    # ---------------- python1.5 extensions
    if ($file =~ m,^usr/lib/python1.5/\S,
	and not $file =~ m,^usr/lib/python1.5/site-packages/,) {
	# check if it's the "python" package itself
	if (not defined $is_python) {
	    $is_python = 0;
	    if (open(SOURCE, "fields/source")) {
		$_ = <SOURCE>;
		$is_python = 1 if /^python($|\s)/;
		close(SOURCE);
	    }
	}
	print "W: $pkg $type: third-party-package-in-python-dir $file\n"
	    unless $is_python;
    }

    # ---------------- license files
    if ($file =~ m,(copying|license)(\.[^/]+)?$,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
	# because preserving working links is more important than saving
	# some bytes.
	and not $file =~ /\.(el|c|h|py|cc|pl|pm|html)$/) {
	print "W: $pkg $type: extra-license-file $file\n";
    }
	

    # ---------------- plain files
    if ($perm =~ /^-/) {
	# ---------------- backup files and autosave files
	if ($file =~ /~$/ or $file =~ m,\#[^/]+\#$,) {
	    print "W: $pkg $type: backup-file-in-package $file\n";
	}

	# ---------------- general: setuid/setgid files!
	if ($perm =~ /s/) {
	    my ($setuid, $setgid);
	    # get more info:
	    my ($user,$group) = $owner =~ m,^(.*)/(.*)$,;
	    $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;
		}
	    }

	    if ($setuid and $setgid) {
		printf "W: $pkg $type: setuid-gid-binary $file %04o $owner\n",$operm;
	    } elsif ($setuid) {
		printf "W: $pkg $type: setuid-binary $file %04o $owner\n",$operm;
	    } elsif ($setgid) {
		printf "W: $pkg $type: setgid-binary $file %04o $owner\n",$operm;
	    } elsif ($operm != $wanted_operm) {
		printf "W: $pkg $type: non-standard-executable-perm $file %04o != %04o\n",$operm,$wanted_operm;
	    }
	}
	# ---------------- general: executable files
	elsif ($perm =~ /[xt]/) {
	    # executable
	    if ($operm != 0755) {
		printf "W: $pkg $type: non-standard-executable-perm $file %04o != 0755\n",$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 != 0644) {
		printf "W: $pkg $type: non-standard-file-perm $file %04o != 0644\n",$operm;
	    }
	}
    }
    # ---------------- directories
    elsif ($perm =~ /^d/) {
	# directory
	# special case first: game directory with setgid bit
	if ($operm == 02775 and $owner =~ m,root/games, and $file =~ m,var/lib/games/\S+,) {
	    # everything is ok
	} elsif ($operm != 0755) {
	    printf "W: $pkg $type: non-standard-dir-perm $file %04o != 0755\n",$operm;
	}
    }
    # ---------------- symbolic links
    elsif ($perm =~ /^l/) {
	# link
	# determine top-level directory of file
	$file =~ m,^/?([^/]+),;
	my $filetop = $1;

	if ($link =~ m,^/([^/]+),) {
	    # absolute link

	    # determine top-level directory of link
	    $link =~ m,^/?([^/]+),;
	    my $linktop = $1;

	    if ($filetop eq $linktop) {
		# absolute links within one toplevel directory are _not_ ok!
		print "E: $pkg $type: symlink-should-be-relative $file $link\n";
	    }
	} else {
	    # relative link

	    my @pathcomponents = split('/', $file);
	    # chop off filename
	    splice(@pathcomponents,$#pathcomponents);

	    # handle `../' at beginning of $link
	    my $my_link = $link;
	    my $lastpop;
	    while ($my_link =~ s,^../,,) {
		if (@pathcomponents) {
		    $lastpop = pop @pathcomponents;
		} else {
		    print "E: $pkg $type: symlink-has-too-many-up-segments $file $link\n";
		    goto NEXT_LINK;
		}
	    }

	    $my_link =~ m,^/?([^/]+),;
	    my $linktop = $1;

	    # does the link go up and then down into the same directory?
	    if ($linktop eq $lastpop) {
		print "W: $pkg $type: lengthy-symlink $file $link\n";
	    }

	    if ($#pathcomponents == -1) {
		# we've reached the root directory
		if ($filetop ne $linktop) {
		    # relative link into other toplevel directory
		    print "E: $pkg $type: symlink-should-be-absolute $file $link\n";
		}
	    }

	    # check additional segments for mistakes like `foo/../bar/'
	    for $linksegment (split('/', $my_link)) {
		if ($linksegment eq '..') {
		    print "E: $pkg $type: symlink-contains-up-and-down-segments $file $link\n";
		    goto NEXT_LINK;
		}
	    }
	}
      NEXT_LINK:
    
	if ($link =~ m,\.(gz|z|Z|zip)\s*$,) {
	    # symlink is pointing to a compressed file

	    # symlink has correct extension?
	    unless ($file =~ m,\.$1\s*$,) {
		print "E: $pkg $type: gzipped-symlink-with-wrong-ext $file $link\n";
	    }
	}
    }
    # ---------------- special files
    else {
	# special file
	printf "E: $pkg $type: special-file $file %04o\n",$operm;
    }
}
close(IN);

exit 0;

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

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

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

    my $o = 0;

    $t =~ /^.(.)(.)(.)(.)(.)(.)(.)(.)(.)/;
  
    $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;
}
