vcs.maemo.org Git - maemian/blob - nokia-lintian/checks/files

   1 # files -- lintian check script -*- perl -*-
   2
   3 # Copyright (C) 1998 Christian Schwarz and Richard Braakman
   4 #
   5 # This program is free software; you can redistribute it and/or modify
   6 # it under the terms of the GNU General Public License as published by
   7 # the Free Software Foundation; either version 2 of the License, or
   8 # (at your option) any later version.
   9 #
  10 # This program is distributed in the hope that it will be useful,
  11 # but WITHOUT ANY WARRANTY; without even the implied warranty of
  12 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  13 # GNU General Public License for more details.
  14 #
  15 # You should have received a copy of the GNU General Public License
  16 # along with this program.  If not, you can find it on the World Wide
  17 # Web at http://www.gnu.org/copyleft/gpl.html, or write to the Free
  18 # Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
  19 # MA 02110-1301, USA.
  20
  21 package Lintian::files;
  22 use strict;
  23 use Dep;
  24 use Tags;
  25 use Util;
  26
  27 sub run {
  28
  29 my $pkg = shift;
  30 my $type = shift;
  31
  32 my $file;
  33 my $source_pkg = "";
  34 my $pkg_section = "";
  35 my $is_python;
  36 my $is_perl;
  37 my $has_binary_perl_file;
  38 my @nonbinary_perl_files_in_lib;
  39
  40 my %is_hard_link;
  41 my %linked_against_libvga;
  42 my %script = ();
  43
  44 # read data from objdump-info file
  45 open(IN, '<', "objdump-info")
  46     or fail("cannot find objdump-info for $type package $pkg");
  47 while (<IN>) {
  48     chop;
  49
  50     next if m/^\s*$/;
  51
  52     if (m,^-- (?:\./)?(\S+)\s*$,) {
  53         $file = $1;
  54     } elsif (m,^\s*NEEDED\s*(\S+),) {
  55         my $lib = $1;
  56         $linked_against_libvga{$file} = 1
  57             if $lib =~ m/libvga/;
  58     }
  59 }
  60 close(IN);
  61
  62 # Get source package name, if possible.
  63 if (open (SOURCE, '<', "fields/source")) {
  64     chomp ($source_pkg = (<SOURCE> || ""));
  65     close SOURCE;
  66 }
  67
  68 # Get section.
  69 if (open (SECTION, '<', "fields/section")) {
  70     chomp ($pkg_section = <SECTION>);
  71     close SECTION;
  72 }
  73
  74 # find out which files are scripts
  75 open(SCRIPTS, '<', "scripts") or fail("cannot open lintian scripts file: $!");
  76 while (<SCRIPTS>) {
  77     chop;
  78     m/^(\S*) (.*)$/ or fail("bad line in scripts file: $_");
  79     $script{$2} = 1;
  80 }
  81 close(SCRIPTS);
  82
  83 # We only want to warn about these once.
  84 my $warned_x11_predepends = 0;
  85 my $warned_debug_name = 0;
  86
  87 my %dir_counts;
  88 my @devhelp;
  89 my @devhelp_links;
  90
  91 # Read package contents...
  92 open(IN, '<', "index") or fail("cannot open index file index: $!");
  93 open(NUMERIC, '<', "index-owner-id")
  94     or fail("cannot open index file index-owner-id: $!");
  95 while (<IN>) {
  96     chop;
  97
  98     my ($perm,$owner,$size,$date,$time,$file) = split(' ', $_, 6);
  99     my $link;
 100     my $operm;
 101
 102     my $numeric = <NUMERIC>;
 103     chop $numeric;
 104     fail("cannot read index file index-owner-id") unless defined $numeric;
 105     my ($owner_id, $file_chk) = (split(' ', $numeric, 6))[1, 5];
 106     fail("mismatching contents of index files: $file $file_chk")
 107         if $file ne $file_chk;
 108
 109     $file =~ s,^\./,,;
 110
 111     if ($file =~ s/ link to (.*)//) {
 112         $is_hard_link{$file} = 1;
 113         my $link_target = $1;
 114         $link_target =~ s,^\./,,;
 115         my $link_target_dir = $link_target;
 116         $link_target_dir =~ s,[^/]*$,,;
 117
 118         # It may look weird to sort the file and link target here, but since
 119         # it's a hard link, both files are equal and either could be
 120         # legitimately reported first.  tar will generate different tar files
 121         # depending on the hashing of the directory, and this sort produces
 122         # stable lintian output despite that.
 123         #
 124         # TODO: actually, policy says 'conffile', not '/etc' -> extend!
 125         tag "package-contains-hardlink", join (' -> ', sort ($file, $link_target))
 126             if $file =~ m,^etc/,
 127                 or $link_target =~ m,^etc/,
 128                 or $file !~ m,^\Q$link_target_dir\E[^/]*$,;
 129     } elsif ($perm =~ m/^l/) {
 130         ($file, $link) = split(' -> ', $file);
 131     }
 132
 133     $operm = perm2oct($perm);
 134
 135     my ($year) = ($date =~ /^(\d{4})/);
 136     if ( $year <= 1984 ) { # value from dak CVS: Dinstall::PastCutOffYear
 137         tag "package-contains-ancient-file", "$file $date";
 138     }
 139
 140     my ($owner_uid, $owner_gid) = split ('/', $owner_id);
 141     if (!($owner_uid < 100 || $owner_uid == 65534
 142           || ($owner_uid >= 60000 && $owner_uid < 65000))
 143         || !($owner_gid < 100 || $owner_gid == 65534
 144              || ($owner_gid >= 60000 && $owner_gid < 65000))) {
 145         tag "wrong-file-owner-uid-or-gid", $file, $owner_id;
 146     }
 147
 148     # *.devhelp and *.devhelp2 files must be accessible from a directory in
 149     # the devhelp search path: /usr/share/devhelp/books and
 150     # /usr/share/gtk-doc/html.  We therefore look for any links in one of
 151     # those directories to another directory.  The presence of such a link
 152     # blesses any file below that other directory.
 153     if ($link and $file =~ m,usr/share/(devhelp/books|gtk-doc/html)/,) {
 154         my $blessed = $link;
 155         if ($blessed !~ m,^/,) {
 156             my $base = $file;
 157             $base =~ s,/+[^/]+$,,;
 158             while ($blessed =~ s,^\.\./,,) {
 159                 $base =~ s,/+[^/]+$,,;
 160             }
 161             $blessed = "$base/$blessed";
 162         }
 163         push (@devhelp_links, $blessed);
 164     }
 165
 166     #count directory contents:
 167     $dir_counts{$file} ||= 0 if ($perm =~ m/^d/);
 168     $dir_counts{$1} = ($dir_counts{$1} || 0) + 1 if ($file =~ m,^(.+/)[^/]+/?$,);
 169
 170     # ---------------- /etc
 171     if ($file =~ m,^etc/,) {
 172         if ($file =~ m,^etc/nntpserver, ) {
 173             tag "package-uses-obsolete-file", "$file";
 174         }
 175         # ---------------- /etc/cron.daily, etc.
 176         elsif ($file =~ m,^etc/cron\.(daily|hourly|monthly|weekly)/[^\.].*\., ) {
 177             tag "run-parts-cron-filename-contains-full-stop", "$file";
 178         }
 179         # ---------------- /etc/cron.d
 180         elsif ($file =~ m,^etc/cron\.d/\S, and $operm != 0644) {
 181             tag "bad-permissions-for-etc-cron.d-script", sprintf("$file %04o != 0644",$operm);
 182         }
 183         # ---------------- /etc/emacs.*
 184         elsif ($file =~ m,^etc/emacs.*/\S, and $perm =~ m/^-/
 185                and $operm != 0644) {
 186             tag "bad-permissions-for-etc-emacs-script", sprintf("$file %04o != 0644",$operm);
 187         }
 188         # ---------------- /etc/gconf/schemas
 189         elsif ($file =~ m,^etc/gconf/schemas/\S,) {
 190             tag "package-installs-into-etc-gconf-schemas", "$file";
 191         }
 192         # ---------------- /etc/init.d
 193         elsif ($file =~ m,^etc/init\.d/\S,
 194                and $file !~ m,^etc/init\.d/(README|skeleton)$,
 195                and $operm != 0755
 196                and $perm =~ m/^-/) {
 197             tag "non-standard-file-permissions-for-etc-init.d-script",
 198                 sprintf("$file %04o != 0755",$operm);
 199         }
 200         #----------------- /etc/pam.conf
 201         elsif ($file =~ m,^etc/pam.conf, and $pkg ne "libpam-runtime" ) {
 202             tag "config-file-reserved", "$file by libpam-runtime";
 203         }
 204         # ---------------- /etc/rc.d
 205         elsif ($type ne 'udeb' and $file =~ m,^etc/rc\.d/\S, and $pkg !~ /^(sysvinit|file-rc)$/) {
 206             tag "package-installs-into-etc-rc.d", "$file";
 207         }
 208         # ---------------- /etc/rc?.d
 209         elsif ($type ne 'udeb' and $file =~ m,^etc/rc(\d|S)\.d/\S, and $pkg !~ /^(sysvinit|file-rc)$/) {
 210             tag "package-installs-into-etc-rc.d", "$file";
 211         }
 212         # ---------------- /etc/rc.boot
 213         elsif ($file =~ m,^etc/rc\.boot/\S,) {
 214             tag "package-installs-into-etc-rc.boot", "$file";
 215         }
 216     }
 217     # ---------------- /usr
 218     elsif ($file =~ m,^usr/,) {
 219         # ---------------- /usr/share/doc
 220         if ($file =~ m,^usr/share/doc/\S,) {
 221             if ($type eq 'udeb') {
 222                 tag "udeb-contains-documentation-file", "$file";
 223             } else {
 224                 # file not owned by root?
 225                 if ($owner ne 'root/root') {
 226                     tag "bad-owner-for-doc-file", "$file $owner != root/root";
 227                 }
 228
 229                 # file directly in /usr/share/doc ?
 230                 if ($perm =~ m/^-/ and $file =~ m,^usr/share/doc/[^/]+$,) {
 231                     tag "file-directly-in-usr-share-doc", "$file";
 232                 }
 233
 234                 # executable in /usr/share/doc ?
 235                 if ($perm =~ m/^-.*[xs]/ and $file !~ m,^usr/share/doc/([^/]+/)?examples/,) {
 236                     if ($script{$file}) {
 237                         tag "script-in-usr-share-doc", "$file";
 238                     } else {
 239                         tag "executable-in-usr-share-doc", $file, (sprintf "%04o", $operm);
 240                     }
 241                 }
 242
 243                 # zero byte file in /usr/share/doc/
 244                 if ($size == 0 and $perm =~ m,^-, and not $is_hard_link{$file}) {
 245                     # exception: examples may contain empty files for various reasons
 246                     unless ($file =~ m,^usr/share/doc/([^/]+/)?examples/,) {
 247                         tag "zero-byte-file-in-doc-directory", "$file";
 248                     }
 249                 }
 250                 # gzipped zero byte files:
 251                 # 276 is 255 bytes (maximal length for a filename) + gzip overhead
 252                 if ($file =~ m,.gz$, and $size <= 276 and $perm =~ m,^-,) {
 253                     unless (`gzip -dc unpacked/$file`) {
 254                         tag "zero-byte-file-in-doc-directory", "$file";
 255                     }
 256                 }
 257
 258                 # override files have moved
 259                 my $tmp = quotemeta($pkg);
 260                 if ($file =~ m,^usr/share/doc/$tmp/override\.[lL]intian(\.gz)?$,) {
 261                     tag "override-file-in-wrong-location", "$file";
 262                 } elsif ($file =~ m,^usr/share/lintian/overrides/$tmp/.*,) {
 263                     tag "override-file-in-wrong-location", "$file";
 264                 }
 265
 266                 # contains an INSTALL file?
 267                 if ($file =~ m,^usr/share/doc/$tmp/INSTALL(?:\..+)*$,) {
 268                     tag "package-contains-upstream-install-documentation", "$file";
 269                 }
 270
 271                 # contains a README for another distribution/platform?
 272                 if ($file =~ m,^usr/share/doc/$tmp/readme\.(apple|aix|atari|be|beos|bsd|bsdi|
 273                                 cygwin|darwin|irix|gentoo|freebsd|mac|macos|macosx|netbsd|
 274                                 openbsd|osf|redhat|sco|sgi|solaris|suse|sun|vms|win32|win9x|
 275                                 windows)(\.txt)?(\.gz)?$,xi){
 276                     tag "package-contains-readme-for-other-platform-or-distro", "$file";\r
 277                 }
 278             }
 279         }
 280         # ---------------- /usr/doc
 281         elsif ($file =~ m,^usr/doc/\S,) {
 282             if ($file =~ m,^usr/doc/examples/\S+, and $perm =~ m/^d/) {
 283                 tag "old-style-example-dir", "$file";
 284             }
 285         }
 286         # ---------------- /usr/X11R6/lib/X11/app-defaults
 287         elsif ($file =~ m,usr/X11R6/lib/X11/app-defaults,) {
 288             tag "old-app-defaults-directory", "$file";
 289         }
 290
 291         #----------------- /usr/{include,lib}/X11/
 292         # Packages installing files here will need to pre-depend on x11-common
 293         # so that the symlinks will be sorted out first on a sarge upgrade.
 294         elsif ($file =~ m,^usr/(?:include|lib)/X11/,
 295                && !$warned_x11_predepends && $pkg ne 'x11-common') {
 296             my $pre_depends = '';
 297             if (open (FH, '<', "fields/pre-depends")) {
 298                 $pre_depends = <FH>;
 299                 close FH;
 300                 $pre_depends =~ s/\n//g;
 301             }
 302             $pre_depends = Dep::parse($pre_depends);
 303             tag "file-in-usr-something-x11-without-pre-depends", "$file"
 304                 unless Dep::implies($pre_depends, Dep::parse('x11-common (>= 1:7.0.0)'));
 305
 306             # Always set this so that we don't redo the check, even if we
 307             # didn't warn.  If the first instance didn't warn, none will.
 308             $warned_x11_predepends = 1;
 309         }
 310
 311         #----------------- /usr/X11R6/
 312         elsif ($file =~ m,^usr/X11R6/bin, && $pkg ne 'x11-common') {
 313             tag "package-installs-file-to-usr-x11r6-bin", "$file";
 314         }
 315         elsif ($file =~ m,^usr/X11R6/lib/X11/fonts,) {
 316             tag "package-installs-font-to-usr-x11r6", "$file";
 317         }
 318         elsif ($file =~ m,^usr/X11R6/, and
 319                $perm !~ m,^l,) { #links to FHS locations are allowed
 320             tag "package-installs-file-to-usr-x11r6", "$file";
 321         }
 322
 323         # ---------------- /usr/lib/debug
 324         elsif ($file =~ m,^usr/lib/debug/\S,) {
 325             unless ($warned_debug_name) {
 326                 tag "debug-package-should-be-named-dbg", "$file"
 327                     unless ($pkg =~ /-dbg$/);
 328                 $warned_debug_name = 1;
 329             }
 330         }
 331
 332         # ---------------- /usr/lib/sgml
 333         elsif ($file =~ m,^usr/lib/sgml/\S,) {
 334             tag "file-in-usr-lib-sgml", $file;
 335         }
 336         # ---------------- perllocal.pod
 337         elsif ($file =~ m,^usr/lib/perl.*/perllocal.pod$,) {
 338             tag "package-installs-perllocal-pod", "$file";
 339         }
 340         # ---------------- .packlist files
 341         elsif ($file =~ m,^usr/lib/perl.*/.packlist$,) {
 342             tag "package-installs-packlist", "$file";
 343         }
 344         elsif ($file =~ m,^usr/lib/perl5/.*\.(pl|pm)$,) {
 345             push @nonbinary_perl_files_in_lib, $file;
 346         }
 347         elsif ($file =~ m,^usr/lib/perl5/.*\.(bs|so)$,) {
 348             $has_binary_perl_file = 1;
 349         }
 350         # ---------------- /usr/lib -- needs to go after the other usr/lib/*
 351         elsif ($file =~ m,^usr/lib/,) {
 352             if ($type ne 'udeb' and $file =~ m,\.(gif|jpeg|jpg|png|tiff|xpm|xbm)$, and not defined $link) {
 353                 tag "image-file-in-usr-lib", "$file"
 354             }
 355         }
 356         # ---------------- /usr/local
 357         elsif ($file =~ m,^usr/local/\S+,) {
 358             if ($perm =~ m/^d/) {
 359                 tag "dir-in-usr-local", "$file";
 360             } else {
 361                 tag "file-in-usr-local", "$file";
 362             }
 363         }
 364         # ---------------- /usr/share/man and /usr/X11R6/man
 365         elsif ($file =~ m,^usr/X11R6/man/\S+, or $file =~ m,^usr/share/man/\S+,) {
 366             if ($type eq 'udeb') {
 367                 tag "documentation-file", "$file";
 368             }
 369             if ($perm =~ m/^d/) {
 370                 tag "stray-directory-in-manpage-directory", "$file"
 371                     if ($file !~ m,^usr/(X11R6|share)/man/(?:[^/]+/)?(man\d/)?$,);
 372             } elsif ($perm =~ m/^-.*[xt]/) {
 373                 tag "executable-manpage", "$file";
 374             }
 375         }
 376         # ---------------- /usr/share/info
 377         elsif ($file =~ m,^usr/share/info\S+,) {
 378             if ($type eq 'udeb') {
 379                 tag "documentation-file", "$file";
 380             }
 381         }
 382         # ---------------- /usr/share/linda/overrides
 383         elsif ($file =~ m,^usr/share/linda/overrides/\S+,) {
 384             tag "package-contains-linda-override", $file;
 385         }
 386         # ---------------- /usr/share
 387         elsif ($file =~ m,^usr/share/[^/]+$,) {
 388             if ($perm =~ m/^-/) {
 389                 tag "file-directly-in-usr-share", "$file";
 390             }
 391         }
 392         # ---------------- /usr/bin
 393         elsif ($file =~ m,^usr/bin/,) {
 394             if ($perm =~ m/^d/ and $file =~ m,^usr/bin/., and $file !~ m,^usr/bin/(X11|mh)/,) {
 395                 tag "subdir-in-usr-bin", "$file";
 396             }
 397         }
 398         # ---------------- /usr subdirs
 399         elsif ($type ne 'udeb' and $file =~ m,^usr/[^/]+/$,) { # FSSTND dirs
 400             if ( $file =~ m,^usr/(dict|doc|etc|info|man|adm|preserve)/,) {
 401                 tag "FSSTND-dir-in-usr", "$file";
 402             }
 403             # FHS dirs
 404             elsif ($file !~ m,^usr/(X11R6|X386|
 405                                     bin|games|include|
 406                                     lib|lib32|lib64|
 407                                     local|sbin|share|
 408                                     src|spool|tmp)/,x) {
 409                 tag "non-standard-dir-in-usr", "$file";
 410             } elsif ($file =~ m,^usr/share/doc,) {
 411                 tag "uses-FHS-doc-dir", "$file";
 412             }
 413
 414             # unless $file =~ m,^usr/[^/]+-linuxlibc1/,; was tied into print
 415             # above...
 416             # Make an exception for the altdev dirs, which will go away
 417             # at some point and are not worth moving.
 418         }
 419         # ---------------- .desktop files
 420         # People have placed them everywhere, but nowadays the consensus seems
 421         # to be to stick to the fd.org standard drafts, which says that
 422         # .desktop files intended for menus should be placed in
 423         # $XDG_DATA_DIRS/applications.  The default for $XDG_DATA_DIRS is
 424         # /usr/local/share/:/usr/share/, according to the basedir-spec on
 425         # fd.org. As distributor, we should only allow /usr/share.
 426         #
 427         # KDE hasn't moved its files from /usr/share/applnk, so don't warn
 428         # about this yet until KDE adopts the new location.
 429         elsif ($file =~ m,^usr/share/gnome/apps/.*\.desktop$,) {
 430             tag "desktop-file-in-wrong-dir", $file;
 431         }
 432
 433     }
 434     # ---------------- /var subdirs
 435     elsif ($type ne 'udeb' and $file =~ m,^var/[^/]+/$,) { # FSSTND dirs
 436         if ( $file =~ m,^var/(adm|catman|named|nis|preserve)/, ) {
 437             tag "FSSTND-dir-in-var", "$file";
 438         }
 439         # FHS dirs with exception in Debian policy
 440         elsif ( $file !~ m,^var/(account|lib|cache|crash|games|lock|log|opt|run|spool|state|tmp|www|yp)/,) {
 441             tag "non-standard-dir-in-var", "$file";
 442         }
 443     }
 444     elsif ($type ne 'udeb' and $file =~ m,^var/lib/games/.,) {
 445         tag "non-standard-dir-in-var", "$file";
 446     }
 447     # ---------------- /var/www
 448     # Packages are allowed to create /var/www since it's historically been the
 449     # default document root, but they shouldn't be installing stuff under that
 450     # directory.
 451     elsif ($file =~ m,^var/www/\S+,) {
 452         tag "dir-or-file-in-var-www", $file;
 453     }
 454     # ---------------- /opt
 455     elsif ($file =~ m,^opt/.,) {
 456         tag "dir-or-file-in-opt", "$file";
 457     }
 458     elsif ($file =~ m,^hurd/.,) {
 459         next;
 460     } elsif ($file =~ m,^server/.,) {
 461         next;
 462     }
 463     # ---------------- /tmp, /var/tmp, /usr/tmp
 464     elsif ($file =~ m,^tmp/., or $file =~ m,^(var|usr)/tmp/.,) {
 465         tag "dir-or-file-in-tmp", "$file";
 466     }
 467     # ---------------- /mnt
 468     elsif ($file =~ m,^mnt/.,) {
 469         tag "dir-or-file-in-mnt", "$file";
 470     }
 471     # ---------------- /bin
 472     elsif ($file =~ m,^bin/,) {
 473         if ($perm =~ m/^d/ and $file =~ m,^bin/.,) {
 474             tag "subdir-in-bin", "$file";
 475         }
 476     }
 477     # ---------------- /srv
 478     elsif ($file =~ m,^srv/.,) {
 479         tag "dir-or-file-in-srv", "$file";
 480     }
 481     # ---------------- FHS directory?
 482     elsif ($file =~ m,^[^/]+/$, and $file ne './' and
 483            $file !~ m,^(bin|boot|dev|etc|home|lib(64|32)?|mnt|opt|root|sbin|srv|tmp|usr|var)/,) {
 484         # Make an exception for the base-files package here and other similar
 485         # packages because they install a slew of top-level directories for
 486         # setting up the base system.  (Specifically, /cdrom, /floppy,
 487         # /initrd, and /proc are not mentioned in the FHS).
 488         #
 489         # Also make an exception for /emul, which is used for multiarch
 490         # support in Debian at the moment.
 491         tag "non-standard-toplevel-dir", "$file"
 492             unless $pkg eq 'base-files'
 493                 or $pkg eq 'hurd'
 494                 or $pkg =~ /^rootskel(-bootfloppy)?/
 495                 or $file =~ m,^emul/,;
 496     }
 497
 498     # ---------------- compatibility symlinks should not be used
 499     if ($file =~ m,^usr/(spool|tmp)/, or
 500         $file =~ m,^usr/(doc|bin)/X11/, or
 501         $file =~ m,^var/adm/,) {
 502         tag "use-of-compat-symlink", "$file";
 503     }
 504
 505     # ---------------- .ali files (Ada Library Information)
 506     if ($file =~ m,^usr/lib/.*\.ali$, && $operm != 0444) {
 507         tag "bad-permissions-for-ali-file", "$file";
 508     }
 509
 510     # ---------------- any files
 511     if ($perm !~ m/^d/) {
 512         unless ($type eq 'udeb'
 513                 or $file =~ m,^usr/(bin|dict|doc|games|
 514                                     include|info|lib(32|64)?|
 515                                     man|sbin|share|src|X11R6)/,x
 516                 or $file =~ m,^lib(32|64)?/(modules/|libc5-compat/)?,
 517                 or $file =~ m,^var/(games|lib|www|named)/,
 518                 or $file =~ m,^(bin|boot|dev|etc|sbin)/,
 519                 # non-FHS, but still usual
 520                 or $file =~ m,^usr/[^/]+-linux[^/]*/,
 521                 or $file =~ m,^usr/iraf/,
 522                 or $file =~ m,^emul/ia32-linux/(lib|usr/lib)/,) {
 523             tag "file-in-unusual-dir", "$file";
 524         }
 525     }
 526
 527     # ---------------- .pyc (compiled python files
 528     if ($file =~ m,^usr/lib/python\d\.\d/.*.pyc$,) {
 529         tag "package-installs-python-pyc", "$file"
 530     }
 531
 532     # ---------------- /usr/lib/site-python
 533     if ($file =~ m,^usr/lib/site-python/\S,) {
 534         tag "file-in-usr-lib-site-python", "$file";
 535     }
 536
 537     # ---------------- pythonX.Y extensions
 538     if ($file =~ m,^usr/lib/python\d\.\d/\S,
 539         and not $file =~ m,^usr/lib/python\d\.\d/site-packages/,) {
 540         # check if it's one of the Python proper packages
 541         unless (defined $is_python) {
 542             $is_python = 0;
 543             if (open(SOURCE, '<', "fields/source")) {
 544                 $_ = <SOURCE>;
 545                 $is_python = 1 if /^python(\d\.\d)?($|\s)/;
 546                 close(SOURCE);
 547             }
 548         }
 549         tag "third-party-package-in-python-dir", "$file"
 550             unless $is_python;
 551     }
 552     # ---------------- perl modules
 553     if ($file =~ m,^usr/(share|lib)/perl/\S,) {
 554        # check if it's the "perl" package itself
 555        unless (defined $is_perl) {
 556            $is_perl = 0;
 557            if (open(SOURCE, '<', "fields/source")) {
 558                $_ = <SOURCE>;
 559                $is_perl = 1 if /^perl($|\s)/;
 560                close(SOURCE);
 561            }
 562        }
 563        tag "perl-module-in-core-directory", "$file"
 564            unless $is_perl;
 565     }
 566
 567     # ---------------- license files
 568     if ($file =~ m,(copying|licen[cs]e)(\.[^/]+)?$,i
 569         # Ignore some common extensions; there was at least one file named
 570         # "license.el".  These are probably license-displaying code, not
 571         # license files.  Also ignore binaries in /usr/bin and friends.
 572         #
 573         # Another exception is made for .html and .php because preserving
 574         # working links is more important than saving some bytes, and
 575         # because a package had a HTML form for licenses called like that.
 576         # Another exception is made for various picture formats since
 577         # those are likely to just be simply pictures.
 578         #
 579         # DTD files are excluded at the request of the Mozilla suite
 580         # maintainers.  Zope products include license files for runtime
 581         # display.  underXXXlicense.docbook files are from KDE.
 582         #
 583         # Ignore extra license files in examples, since various package
 584         # building software includes example packages with licenses.
 585         and not $file =~ m/\.(el|c|h|py|cc|pl|pm|html|php|rb|xpm|png|jpe?g|gif|svg|dtd)$/
 586         and not $file =~ m,^usr/share/zope/Products/.*\.(dtml|pt|cpt)$,
 587         and not $file =~ m,/under\S+License\.docbook$,
 588         and not $file =~ m,^(usr/)?s?bin/,
 589         and not $file =~ m,^usr/share/doc/[^/]+/examples/,
 590         and not defined $link) {
 591         tag "extra-license-file", "$file";
 592     }
 593
 594     # ---------------- .devhelp2? files
 595     if ($file =~ m,\.devhelp2?(\.gz)?$,
 596         # If the file is located in a directory not searched by devhelp, we
 597         # check later to see if it's in a symlinked directory.
 598         and not $file =~ m,^usr/share/(devhelp/books|gtk-doc/html)/,
 599         and not $file =~ m,^usr/share/doc/[^/]+/examples/,) {
 600         push (@devhelp, $file);
 601     }
 602
 603     # ---------------- weird file names
 604     if ($file =~ m,\s+\z,) {
 605         tag "file-name-ends-in-whitespace", "$file";
 606     }
 607
 608     # ---------------- plain files
 609     if ($perm =~ m/^-/) {
 610         my $wanted_operm;
 611         # ---------------- backup files and autosave files
 612         if ($file =~ /~$/ or $file =~ m,\#[^/]+\#$, or $file =~ m,/\.[^/]+\.swp$,) {
 613             tag "backup-file-in-package", "$file";
 614         }
 615         if ($file =~ m,/\.nfs[^/]+$,) {
 616             tag "nfs-temporary-file-in-package", "$file";
 617         }
 618
 619         # ---------------- vcs control files
 620         if ($file =~ m/\.((cvs|git|hg)ignore|arch-inventory|hgtags|hg_archival\.txt)$/) {
 621             tag "package-contains-vcs-control-file", "$file";
 622         }
 623
 624         # ---------------- subversion and svk commit message backups
 625         if ($file =~ m/svn-commit.*\.tmp$/) {
 626             tag "svn-commit-file-in-package", "$file";
 627         }
 628         if ($file =~ m/svk-commit.+\.tmp$/) {
 629             tag "svk-commit-file-in-package", "$file";
 630         }
 631
 632         # ---------------- executables with language extensions
 633         if ($file =~ m,^(usr/)?(s?bin|games)/[^/]+\.(pl|sh|py|php|rb|tcl|bsh|csh|tcl)$,) {
 634             tag "script-with-language-extension", "$file";
 635         }
 636
 637         # ---------------- Autogenerated databases from other OSes
 638         if ($file =~ m,/Thumbs\.db(\.gz)?$,i) {
 639             tag "windows-thumbnail-database-in-package", "$file";
 640         }
 641         if ($file =~ m,/\.DS_Store(\.gz)?$,) {
 642             tag "macos-ds-store-file-in-package", "$file";
 643         }
 644         if ($file =~ m,/\._[^_/][^/]*$, and $file !~ m/\.swp$/) {
 645             tag "macos-resource-fork-file-in-package", "$file";
 646         }
 647
 648         # ---------------- embedded Javascript libraries
 649         if ($file =~ m,/(mochikit|
 650                          jquery(\.(min|lite|pack))?|
 651                          prototype(-[\d\.]+)?|
 652                          scriptaculous|
 653                          fckeditor|
 654                          cropper(\.uncompressed)?
 655                         )\.js(\.gz)?$,ix) {
 656             tag "embedded-javascript-library", "$file";
 657         }
 658
 659         # ---------------- general: setuid/setgid files!
 660         if ($perm =~ m/s/) {
 661             my ($setuid, $setgid) = ("","");
 662             # get more info:
 663             my ($user,$group) = ("", "");
 664
 665             if ($owner =~ m,^(.*)/(.*)$,) {
 666                 $user = $1;
 667                 $group = $2;
 668             }
 669             $setuid = $user if ($operm & 04000);
 670             $setgid = $group if ($operm & 02000);
 671
 672             # 1st special case: program is using svgalib:
 673             if (exists $linked_against_libvga{$file}) {
 674                 # setuid root is ok, so remove it
 675                 if ($setuid eq 'root') {
 676                     undef $setuid;
 677                 }
 678             }
 679
 680             # 2nd special case: program is a setgid game
 681             if ($file =~ m,usr/lib/games/\S+, or $file =~ m,usr/games/\S+,) {
 682                 # setgid games is ok, so remove it
 683                 if ($setgid eq 'games') {
 684                     undef $setgid;
 685                 }
 686             }
 687
 688             # 3rd special case: allow anything with suid in the name
 689             if ($pkg =~ m,-suid,) {
 690                 undef $setuid;
 691             }
 692
 693             # Check for setuid and setgid that isn't expected.
 694             if ($setuid and $setgid) {
 695                 tag "setuid-gid-binary", $file, sprintf("%04o $owner",$operm);
 696             } elsif ($setuid) {
 697                 tag "setuid-binary", $file, sprintf("%04o $owner",$operm);
 698             } elsif ($setgid) {
 699                 tag "setgid-binary", $file, sprintf("%04o $owner",$operm);
 700             }
 701
 702             # Check for permission problems other than the setuid status.
 703             if (($operm & 0444) != 0444) {
 704                 tag "executable-is-not-world-readable", $file,
 705                     sprintf("%04o",$operm);
 706             } elsif ($operm != 04755 && $operm != 02755 && $operm != 06755 && $operm != 04754) {
 707                 tag "non-standard-setuid-executable-perm", $file,
 708                     sprintf("%04o",$operm);
 709             }
 710         }
 711         # ---------------- general: executable files
 712         elsif ($perm =~ m/[xt]/) {
 713             # executable
 714             if ($owner =~ m,root/games,) {
 715                 if ($operm != 2755) {
 716                     tag "non-standard-game-executable-perm", $file,
 717                         sprintf("%04o != 2755",$operm);
 718                 }
 719             } else {
 720                 if (($operm & 0444) != 0444) {
 721                     tag "executable-is-not-world-readable", $file,
 722                         sprintf("%04o != 0755",$operm);
 723                 } elsif ($operm != 0755) {
 724                     tag "non-standard-executable-perm", $file,
 725                         sprintf("%04o != 0755",$operm);
 726                 }
 727             }
 728         }
 729         # ---------------- general: normal (non-executable) files
 730         else {
 731             # not executable
 732             # special case first: game data
 733             if ($operm == 0664 and $owner =~ m,root/games, and
 734                 $file =~ m,var/(lib/)?games/\S+,) {
 735                 # everything is ok
 736             } elsif ($operm == 0444 and $file =~ m,usr/lib/.*\.ali$,) {
 737                 # Ada library information files should be read-only
 738                 # since GNAT behaviour depends on that
 739                 # everything is ok
 740             } elsif ($operm == 0600 and $file =~ m,etc/backup.d/,) {
 741                 # backupninja expects configurations files to be 0600
 742             } elsif ($operm != 0644) {
 743                 tag "non-standard-file-perm", $file,
 744                     sprintf("%04o != 0644",$operm);
 745             }
 746         }
 747     }
 748     # ---------------- directories
 749     elsif ($perm =~ m/^d/) {
 750         # special cases first:
 751         # game directory with setgid bit
 752         if ($file =~ m,var/(lib/)?games/\S+, and $operm == 02775
 753             and $owner =~ m,root/games,) {
 754             # do nothing, this is allowed, but not mandatory
 755         }
 756         # otherwise, complain if it's not 0755.
 757         elsif ($operm != 0755) {
 758             tag "non-standard-dir-perm", $file,
 759                 sprintf("%04o != 0755", $operm);
 760         }
 761         if ($file =~ m,/CVS/?$,) {
 762             tag "package-contains-vcs-control-dir", "$file";
 763         }
 764         if ($file =~ m,/\.(svn|bzr|git|hg)/?$,) {
 765             tag "package-contains-vcs-control-dir", "$file";
 766         }
 767         if (($file =~ m,/\.arch-ids/?$,)
 768             || ($file =~ m,/\{arch\}/?$,)) {
 769             tag "package-contains-vcs-control-dir", "$file";
 770         }
 771         if ($file =~ m,/\.(be|ditrack)/?$,) {
 772             tag "package-contains-bts-control-dir", "$file";
 773         }
 774         if ($file =~ m,/.xvpics/?$,) {
 775             tag "package-contains-xvpics-dir", "$file";
 776         }
 777         if ($file =~ m,usr/share/doc/[^/]+/examples/examples/?$,) {
 778             tag "nested-examples-directory", "$file";
 779         }
 780     }
 781     # ---------------- symbolic links
 782     elsif ($perm =~ m/^l/) {
 783         # link
 784
 785         my $mylink = $link;
 786         if ($mylink =~ s,//+,/,g) {
 787             tag "symlink-has-double-slash", "$file $link";
 788         }
 789         if ($mylink =~ s,(.)/$,$1,) {
 790             tag "symlink-ends-with-slash", "$file $link";
 791         }
 792
 793         # determine top-level directory of file
 794         $file =~ m,^/?([^/]*),;
 795         my $filetop = $1;
 796
 797         if ($mylink =~ m,^/([^/]*),) {
 798             # absolute link, including link to /
 799
 800             # determine top-level directory of link
 801             $mylink =~ m,^/([^/]*),;
 802             my $linktop = $1;
 803
 804             if ($type ne 'udeb' and $filetop eq $linktop) {
 805                 # absolute links within one toplevel directory are _not_ ok!
 806                 tag "symlink-should-be-relative", "$file $link";
 807             }
 808
 809             # Any other case is already definitely non-recursive
 810             tag "symlink-is-self-recursive", "$file $link"
 811                 if $mylink eq '/';
 812
 813         } else {
 814             # relative link, we can assume from here that the link starts nor
 815             # ends with /
 816
 817             my @filecomponents = split('/', $file);
 818             # chop off the name of the symlink
 819             pop @filecomponents;
 820
 821             my @linkcomponents = split('/', $mylink);
 822
 823             # handle `../' at beginning of $link
 824             my $lastpop = undef;
 825             my $linkcomponent = undef;
 826             while ($linkcomponent = shift @linkcomponents) {
 827                 if ($linkcomponent eq '.') {
 828                     tag "symlink-contains-spurious-segments", "$file $link"
 829                         unless $mylink eq '.';
 830                     next;
 831                 }
 832                 last if $linkcomponent ne '..';
 833                 if (@filecomponents) {
 834                     $lastpop = pop @filecomponents;
 835                 } else {
 836                     tag "symlink-has-too-many-up-segments", "$file $link";
 837                     goto NEXT_LINK;
 838                 }
 839             }
 840
 841             if (!defined $linkcomponent) {
 842                 # After stripping all starting .. components, nothing left
 843                 tag "symlink-is-self-recursive", "$file $link";
 844             }
 845
 846             # does the link go up and then down into the same directory?
 847             # (lastpop indicates there was a backref at all, no linkcomponent
 848             # means the symlink doesn't get up anymore)
 849             if (defined $lastpop && defined $linkcomponent &&
 850                 $linkcomponent eq $lastpop) {
 851                 tag "lengthy-symlink", "$file $link";
 852             }
 853
 854             if ($#filecomponents == -1) {
 855                 # we've reached the root directory
 856                 if (($type ne 'udeb')
 857                     && (!defined $linkcomponent)
 858                     || ($filetop ne $linkcomponent)) {
 859                     # relative link into other toplevel directory.
 860                     # this hits a relative symbolic link in the root too.
 861                     tag "symlink-should-be-absolute", "$file $link";
 862                 }
 863             }
 864
 865             # check additional segments for mistakes like `foo/../bar/'
 866             foreach (@linkcomponents) {
 867                 if ($_ eq '..' || $_ eq '.') {
 868                     tag "symlink-contains-spurious-segments", "$file $link";
 869                     last;
 870                 }
 871             }
 872         }
 873     NEXT_LINK:
 874
 875         if ($link =~ m,\.(gz|z|Z|bz|bz2|tgz|zip)\s*$,) {
 876             # symlink is pointing to a compressed file
 877
 878             # symlink has correct extension?
 879             unless ($file =~ m,\.$1\s*$,) {
 880                 tag "compressed-symlink-with-wrong-ext", "$file $link";
 881             }
 882         }
 883     }
 884     # ---------------- special files
 885     else {
 886         # special file
 887         tag "special-file", $file, sprintf("%04o",$operm);
 888     }
 889 }
 890 close(IN);
 891
 892 fail("mismatching contents of index files") if defined <NUMERIC>;
 893 close(NUMERIC);
 894
 895 #check for sect: games but nothing in /usr/games. Check for any binary to
 896 #save ourselves from game-data false positives:
 897 if ($pkg_section =~ m,games$,
 898     and (($dir_counts{"usr/games/"} || 0) == 0)
 899     and (($dir_counts{"bin/"} || 0) + ($dir_counts{"usr/bin/"} || 0)) > 0) {
 900     tag "package-section-games-but-contains-no-game";
 901 }
 902
 903 if ($pkg_section =~ m,games$,
 904     and (($dir_counts{"usr/games/"} || 0)> 0)
 905     and (($dir_counts{"bin/"} || 0) + ($dir_counts{"usr/bin/"} || 0)) > 0) {
 906     tag "package-section-games-but-has-usr-bin";
 907 }
 908
 909 # Warn about empty directories, but ignore empty directories in /var (packages
 910 # create directories to hold dynamically created data) or /etc (configuration
 911 # files generated by maintainer scripts).  Also skip base-files, which is a
 912 # very special case.
 913 #
 914 # Empty Perl directories are an ExtUtils::MakeMaker artifact that will be
 915 # fixed in Perl 5.10, and people can cause more problems by trying to fix it,
 916 # so just ignore them.
 917 #
 918 # python-support needs a directory for each package even it might be empty
 919 foreach my $dir (keys %dir_counts) {
 920     next if $dir eq "";
 921     next if ($dir =~ m{^var/} or $dir =~ m{^etc/});
 922     next if $pkg eq 'base-files';
 923     if ($dir_counts{$dir} == 0) {
 924         if ($dir ne 'usr/lib/perl5/'
 925             and $dir ne 'usr/share/perl5/'
 926             and $dir !~ m;^usr/share/python-support/;) {
 927             tag "package-contains-empty-directory", $dir;
 928         }
 929     }
 930 }
 931
 932 if (!$has_binary_perl_file && @nonbinary_perl_files_in_lib) {
 933     foreach my $file (@nonbinary_perl_files_in_lib) {
 934         tag "package-installs-nonbinary-perl-in-usr-lib-perl5", "$file";
 935     }
 936 }
 937
 938 # Check for .devhelp2? files that aren't symlinked into paths searched by
 939 # devhelp.
 940 for my $file (@devhelp) {
 941     my $found = 0;
 942     for my $link (@devhelp_links) {
 943         if ($file =~ m,^\Q$link,) {
 944             $found = 1;
 945             last;
 946         }
 947     }
 948     tag 'package-contains-devhelp-file-without-symlink', $file unless $found;
 949 }
 950
 951 }
 952
 953 1;
 954
 955 # Local Variables:
 956 # indent-tabs-mode: t
 957 # cperl-indent-level: 4
 958 # End:
 959 # vim: syntax=perl ts=8 sw=4